From: Dan Fandrich Date: Tue, 28 Mar 2023 02:58:00 +0000 (-0700) Subject: tests: silence some Perl::Critic warnings in test suite X-Git-Tag: curl-8_1_0~254 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=b133f70a52703ccc6469280ae141643bcc06a685;p=thirdparty%2Fcurl.git tests: silence some Perl::Critic warnings in test suite Not all warnings are fixed; many are as much stylistic suggestions than anything and IMHO don't do much to actually improve the code. Ref: #10818 Closes #10861 --- diff --git a/tests/ftp.pm b/tests/ftp.pm index 6edee3daef..59a203e877 100644 --- a/tests/ftp.pm +++ b/tests/ftp.pm @@ -22,6 +22,9 @@ # ########################################################################### +use strict; +use warnings; + BEGIN { # portable sleeping needs Time::HiRes eval { @@ -35,9 +38,6 @@ BEGIN { } } -use strict; -use warnings; - use serverhelp qw( servername_id mainsockf_pidfilename @@ -82,7 +82,7 @@ sub pidfromfile { if(-f $pidfile && -s $pidfile && open(PIDFH, "<$pidfile")) { $pid = 0 + ; close(PIDFH); - $pid = 0 unless($pid > 0); + $pid = 0 if($pid < 0); } return $pid; } @@ -230,8 +230,8 @@ sub processexists { # with a SIGTERM signal and SIGKILLs those which haven't died on time. # sub killpid { - use POSIX ":sys_wait_h"; my ($verbose, $pidlist) = @_; + use POSIX ":sys_wait_h"; my @requested; my @signalled; my @reapchild; @@ -380,8 +380,7 @@ sub killallsockfilters { sub set_advisor_read_lock { my ($filename) = @_; - if(open(FILEH, ">$filename")) { - close(FILEH); + if(open(FILEH, ">$filename") && close(FILEH)) { return; } printf "Error creating lock file $filename error: $!"; diff --git a/tests/getpart.pm b/tests/getpart.pm index fac10dd271..6a22d976aa 100644 --- a/tests/getpart.pm +++ b/tests/getpart.pm @@ -22,7 +22,8 @@ # ########################################################################### -#use strict; +use strict; +use warnings; use Memoize; use MIME::Base64; @@ -309,12 +310,12 @@ sub compareparts { sub writearray { my ($filename, $arrayref)=@_; - open(TEMP, ">$filename"); + open(TEMP, ">$filename") || die "Failure writing file"; binmode(TEMP,":raw"); # cygwin fix by Kevin Roth for(@$arrayref) { print TEMP $_; } - close(TEMP); + close(TEMP) || die "Failure writing file"; } # @@ -341,7 +342,7 @@ sub showdiff { my $file1="$logdir/check-generated"; my $file2="$logdir/check-expected"; - open(TEMP, ">$file1"); + open(TEMP, ">$file1") || die "Failure writing diff file"; for(@$firstref) { my $l = $_; $l =~ s/\r/[CR]/g; @@ -350,9 +351,9 @@ sub showdiff { print TEMP $l; print TEMP "\n"; } - close(TEMP); + close(TEMP) || die "Failure writing diff file"; - open(TEMP, ">$file2"); + open(TEMP, ">$file2") || die "Failure writing diff file"; for(@$secondref) { my $l = $_; $l =~ s/\r/[CR]/g; @@ -361,7 +362,7 @@ sub showdiff { print TEMP $l; print TEMP "\n"; } - close(TEMP); + close(TEMP) || die "Failure writing diff file"; my @out = `diff -u $file2 $file1 2>/dev/null`; if(!$out[0]) { diff --git a/tests/pathhelp.pm b/tests/pathhelp.pm index b7b312151d..9a8448c9a5 100644 --- a/tests/pathhelp.pm +++ b/tests/pathhelp.pm @@ -56,9 +56,7 @@ use warnings; use Cwd 'abs_path'; BEGIN { - require Exporter; - - our @ISA = qw(Exporter); + use base qw(Exporter); our @EXPORT = qw( sys_native_abs_path @@ -109,7 +107,7 @@ our $use_cygpath; # Only for Win32: # Returns boolean true if 'cygpath' utility should be used for path conversion. sub should_use_cygpath { - unless (os_is_win()) { + if(!os_is_win()) { $use_cygpath = 0; return 0; } @@ -134,7 +132,7 @@ sub normalize_path; # Returns current working directory in Win32 format on Windows. # sub sys_native_current_path { - return Cwd::getcwd() unless os_is_win(); + return Cwd::getcwd() if !os_is_win(); my $cur_dir; if($^O eq 'msys') { @@ -203,7 +201,7 @@ sub sys_native_path { my ($path) = @_; # Return untouched on non-Windows platforms. - return $path unless (os_is_win()); + return $path if (!os_is_win()); # Do not process empty path. return $path if ($path eq ''); @@ -233,7 +231,7 @@ sub sys_native_path { # Convert leading slash back to forward slash to indicate # directory on Win32 current drive or capitalize drive letter. - substr($path, 0, 1) = $first_char; + substr($path, 0, 1, $first_char); return $path; } elsif(should_use_cygpath()) { @@ -266,7 +264,7 @@ sub sys_native_path { # program parameters if program is not Msys-based. $path = do_msys_transform($path); - return undef unless defined $path; + return undef if !defined $path; # Capitalize drive letter for Win32 paths. $path =~ s{^([a-z]:)}{\u$1}; @@ -303,7 +301,7 @@ sub sys_native_path { sub sys_native_abs_path { my ($path) = @_; - unless(os_is_win()) { + if(!os_is_win()) { # Convert path to absolute form. $path = Cwd::abs_path($path); @@ -362,7 +360,7 @@ sub sys_native_abs_path { # Path is directory or filename on Win32 current drive. ('\Windows') my $w32drive = get_win32_current_drive(); - return undef unless defined $w32drive; + return undef if !defined $w32drive; # Combine drive and path. # Replace any possible back slashes with forward slashes, @@ -370,7 +368,7 @@ sub sys_native_abs_path { return normalize_path($w32drive . $path); } - unless (substr($path, 0, 1) eq '/') { + if(substr($path, 0, 1) ne '/') { # Path is in relative form. Resolve relative directories in Unix form # *BEFORE* converting to Win32 form otherwise paths like # '../../../cygdrive/c/windows' will not be resolved. @@ -400,7 +398,7 @@ sub sys_native_abs_path { # Msys transforms automatically path to Windows native form in staring # program parameters if program is not Msys-based. $path = do_msys_transform($path); - return undef unless defined $path; + return undef if !defined $path; # Replace any back and duplicated slashes with single forward slashes. $path =~ s{[\\/]+}{/}g; @@ -423,7 +421,7 @@ sub simple_transform_win32_to_unix; sub build_sys_abs_path { my ($path) = @_; - unless(os_is_win()) { + if(!os_is_win()) { # Convert path to absolute form. $path = Cwd::abs_path($path); @@ -442,7 +440,7 @@ sub build_sys_abs_path { # Replace any possible back slashes with forward slashes, # remove any duplicated slashes. $path = get_abs_path_on_win32_drive($1, $2); - return undef unless defined $path; + return undef if !defined $path; return simple_transform_win32_to_unix($path); } @@ -475,7 +473,7 @@ sub build_sys_abs_path { # Unix-style paths. # Remove duplicated slashes, as they may be not processed. $path = normalize_path($path); - return undef unless defined $path; + return undef if !defined $path; # Use 'cygpath', '-u' means Unix-stile path, # '-a' means absolute path @@ -500,7 +498,7 @@ sub build_sys_abs_path { # Replace any possible back slashes with forward slashes, # remove any duplicated slashes. $path = normalize_path($path); - return undef unless defined $path; + return undef if !defined $path; return simple_transform_win32_to_unix($path); } @@ -508,7 +506,7 @@ sub build_sys_abs_path { # Path is directory or filename on Win32 current drive. ('\Windows') my $w32drive = get_win32_current_drive(); - return undef unless defined $w32drive; + return undef if !defined $w32drive; # Combine drive and path. # Resolve relative dirs in Win32-style path or paths like 'D:/../c/' @@ -516,13 +514,13 @@ sub build_sys_abs_path { # Replace any possible back slashes with forward slashes, # remove any duplicated slashes. $path = normalize_path($w32drive . $path); - return undef unless defined $path; + return undef if !defined $path; return simple_transform_win32_to_unix($path); } # Path is not in any Win32 form. - unless (substr($path, 0, 1) eq '/') { + if(substr($path, 0, 1) ne '/') { # Path in relative form. Resolve relative directories in Unix form # *BEFORE* converting to Win32 form otherwise paths like # '../../../cygdrive/c/windows' will not be resolved. @@ -561,12 +559,12 @@ sub normalize_path { # Don't process empty paths. return $path if $path eq ''; - unless($path =~ m{(?:^|\\|/)\.{1,2}(?:\\|/|$)}) { + if($path !~ m{(?:^|\\|/)\.{1,2}(?:\\|/|$)}) { # Speed up processing of simple paths. my $first_char = substr($path, 0, 1); $path =~ s{[\\/]+}{/}g; # Restore starting backslash if any. - substr($path, 0, 1) = $first_char; + substr($path, 0, 1, $first_char); return $path; } @@ -581,7 +579,7 @@ sub normalize_path { # Process path separately from drive letter. @arr = split(m{\/|\\}, $3); # Replace backslash with forward slash if required. - substr($prefix, 2, 1) = '/' if $have_root; + substr($prefix, 2, 1, '/') if $have_root; } else { if($path =~ m{^(\/|\\)}) { @@ -601,7 +599,7 @@ sub normalize_path { if(length($el) == 0 || $el eq '.') { next; } - elsif($el eq '..' && @res > 0 && $res[$#res] ne '..') { + elsif($el eq '..' && @res > 0 && $res[-1] ne '..') { pop @res; next; } @@ -717,7 +715,7 @@ sub do_dumb_guessed_transform { # '/bin/' can be mapped to '/usr/bin/'. my $check_path = $path; my $path_tail = ''; - do { + while(1) { if(-d $check_path) { my $res = `(cd "$check_path" && cmd /c "echo %__CD__%") 2>/dev/null`; @@ -732,7 +730,7 @@ sub do_dumb_guessed_transform { return $res . $path_tail; } else { - $res =~ s{/$}{} unless $check_path =~ m{/$}; + $res =~ s{/$}{} if $check_path !~ m{/$}; return $res; } } @@ -747,7 +745,7 @@ sub do_dumb_guessed_transform { warn "Can't determine Win32 directory for path \"$path\".\n"; return undef; } - } while(1); + } } @@ -772,7 +770,7 @@ sub simple_transform_win32_to_unix { } # 'cygpath' is not available, use guessed transformation. - unless($path =~ s{^([a-zA-Z]):(?:/|\\)}{/\l$1/}) { + if($path !~ s{^([a-zA-Z]):(?:/|\\)}{/\l$1/}) { warn "Can't determine Unix-style directory for Win32 " . "directory \"$path\".\n"; return undef; diff --git a/tests/runtests.pl b/tests/runtests.pl index 79c7f40890..b61e7119fe 100755 --- a/tests/runtests.pl +++ b/tests/runtests.pl @@ -54,6 +54,10 @@ # fixed. As long as the -g option is never given, and the -n is always # given, this won't be a problem. +use strict; +# Promote all warnings to fatal +use warnings FATAL => 'all'; +use 5.006; # These should be the only variables that might be needed to get edited: @@ -74,10 +78,6 @@ BEGIN { } } -use 5.006; -use strict; -# Promote all warnings to fatal -use warnings FATAL => 'all'; use Cwd; use Digest::MD5 qw(md5); use MIME::Base64; @@ -121,11 +121,11 @@ use sshhelp qw( use pathhelp; -require "getpart.pm"; # array functions -require "valgrind.pm"; # valgrind report parser -require "ftp.pm"; -require "azure.pm"; -require "appveyor.pm"; +require getpart; # array functions +require valgrind; # valgrind report parser +require ftp; +require azure; +require appveyor; my $HOSTIP="127.0.0.1"; # address on which the test server listens my $HOST6IP="[::1]"; # address on which the test server listens @@ -142,7 +142,7 @@ my %custom_skip_reasons; my $SSHSRVMD5 = "[uninitialized]"; # MD5 of ssh server public key my $SSHSRVSHA256 = "[uninitialized]"; # SHA256 of ssh server public key -my $VERSION=""; # curl's reported version number +my $CURLVERSION=""; # curl's reported version number my $srcdir = $ENV{'srcdir'} || '.'; my $CURL="../src/curl".exe_ext('TOOL'); # what curl binary to run on the tests @@ -279,7 +279,6 @@ my %runcert; # cert file currently in use by an ssl running server # torture test variables my $torture; -my $tortnum; my $tortalloc; my $shallow; my $randseed = 0; @@ -334,8 +333,7 @@ $SIG{TERM} = \&catch_zap; # Clear all possible '*_proxy' environment variables for various protocols # to prevent them to interfere with our testing! -my $protocol; -foreach $protocol (('ftp', 'http', 'ftps', 'https', 'no', 'all')) { +foreach my $protocol (('ftp', 'http', 'ftps', 'https', 'no', 'all')) { my $proxy = "${protocol}_proxy"; # clear lowercase version delete $ENV{$proxy} if($ENV{$proxy}); @@ -419,11 +417,11 @@ sub init_serverpidfile_hash { # Check if a given child process has just died. Reaps it if so. # sub checkdied { - use POSIX ":sys_wait_h"; my $pid = $_[0]; if((not defined $pid) || $pid <= 0) { return 0; } + use POSIX ":sys_wait_h"; my $rc = pidwait($pid, &WNOHANG); return ($rc == $pid)?1:0; } @@ -464,7 +462,7 @@ sub startnew { if ($fake) { if(open(OUT, ">$pidfile")) { print OUT $child . "\n"; - close(OUT); + close(OUT) || die "Failure writing pidfile"; logmsg "startnew: $pidfile faked with pid=$child\n" if($verbose); } else { @@ -517,7 +515,7 @@ sub startnew { # sub checkcmd { my ($cmd)=@_; - my @paths=(split(":", $ENV{'PATH'}), "/usr/sbin", "/usr/local/sbin", + my @paths=(split(m/[:]/, $ENV{'PATH'}), "/usr/sbin", "/usr/local/sbin", "/sbin", "/usr/bin", "/usr/local/bin", "$LIBDIR/.libs", "$LIBDIR"); for(@paths) { @@ -526,6 +524,7 @@ sub checkcmd { return "$_/$cmd"; } } + return ""; } ####################################################################### @@ -1032,7 +1031,7 @@ sub verifyrtsp { logmsg "RUN: curl command returned $res\n"; if(open(FILE, "<$verifylog")) { while(my $string = ) { - logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); + logmsg "RUN: $string" if($string !~ /^[ \t]*$/); } close(FILE); } @@ -1445,7 +1444,7 @@ sub responsiveserver { # start the http2 server # sub runhttp2server { - my ($verbose) = @_; + my ($verb) = @_; my $server; my $srvrname; my $pidfile; @@ -1501,7 +1500,7 @@ sub runhttp2server { } $doesntrun{$pidfile} = 0; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $http2pid ". "http-port $port https-port $port2 ". "backend $HOSTIP:" . protoport("http") . "\n"; @@ -1518,7 +1517,7 @@ sub runhttp2server { # start the http3 server # sub runhttp3server { - my ($verbose, $cert) = @_; + my ($verb, $cert) = @_; my $server; my $srvrname; my $pidfile; @@ -1573,7 +1572,7 @@ sub runhttp3server { } $doesntrun{$pidfile} = 0; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $http3pid port $port\n"; } last; @@ -1588,7 +1587,7 @@ sub runhttp3server { # start the http server # sub runhttpserver { - my ($proto, $verbose, $alt, $port_or_path) = @_; + my ($proto, $verb, $alt, $port_or_path) = @_; my $ip = $HOSTIP; my $ipvnum = 4; my $idnum = 1; @@ -1677,7 +1676,7 @@ sub runhttpserver { } $pid2 = $pid3; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server is on PID $httppid port $port_or_path\n"; } @@ -1688,7 +1687,7 @@ sub runhttpserver { # start the https stunnel based server # sub runhttpsserver { - my ($verbose, $proto, $proxy, $certfile) = @_; + my ($verb, $proto, $proxy, $certfile) = @_; my $ip = $HOSTIP; my $ipvnum = 4; my $idnum = 1; @@ -1764,7 +1763,7 @@ sub runhttpsserver { next; } # we have a server! - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server is PID $httpspid port $port\n"; } last; @@ -1779,7 +1778,7 @@ sub runhttpsserver { # start the non-stunnel HTTP TLS extensions capable server # sub runhttptlsserver { - my ($verbose, $ipv6) = @_; + my ($verb, $ipv6) = @_; my $proto = "httptls"; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; @@ -1838,7 +1837,7 @@ sub runhttptlsserver { } $doesntrun{$pidfile} = 0; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $httptlspid port $port\n"; } last; @@ -1851,7 +1850,7 @@ sub runhttptlsserver { # start the pingpong server (FTP, POP3, IMAP, SMTP) # sub runpingpongserver { - my ($proto, $id, $verbose, $ipv6) = @_; + my ($proto, $id, $verb, $ipv6) = @_; my $port; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; @@ -1904,7 +1903,7 @@ sub runpingpongserver { # where is it? $port = pidfromfile($portfile); - logmsg "PINGPONG runs on port $port ($portfile)\n" if($verbose); + logmsg "PINGPONG runs on port $port ($portfile)\n" if($verb); # Server is up. Verify that we can speak to it. my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); @@ -1918,7 +1917,7 @@ sub runpingpongserver { } $pid2 = $pid3; - logmsg "RUN: $srvrname server is PID $ftppid port $port\n" if($verbose); + logmsg "RUN: $srvrname server is PID $ftppid port $port\n" if($verb); # Assign the correct port variable! if($proto =~ /^(?:ftp|imap|pop3|smtp)$/) { @@ -1936,7 +1935,7 @@ sub runpingpongserver { # start the ftps/imaps/pop3s/smtps server (or rather, tunnel) # sub runsecureserver { - my ($verbose, $ipv6, $certfile, $proto, $clearport) = @_; + my ($verb, $ipv6, $certfile, $proto, $clearport) = @_; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; my $idnum = 1; @@ -2002,7 +2001,7 @@ sub runsecureserver { $doesntrun{$pidfile} = 0; $runcert{$server} = $certfile; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server is PID $protospid port $port\n"; } last; @@ -2017,7 +2016,7 @@ sub runsecureserver { # start the tftp server # sub runtftpserver { - my ($id, $verbose, $ipv6) = @_; + my ($id, $verb, $ipv6) = @_; my $ip = $HOSTIP; my $proto = 'tftp'; my $ipvnum = 4; @@ -2087,7 +2086,7 @@ sub runtftpserver { } $pid2 = $pid3; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server on PID $tftppid port $port\n"; } @@ -2099,7 +2098,7 @@ sub runtftpserver { # start the rtsp server # sub runrtspserver { - my ($verbose, $ipv6) = @_; + my ($verb, $ipv6) = @_; my $ip = $HOSTIP; my $proto = 'rtsp'; my $ipvnum = 4; @@ -2169,7 +2168,7 @@ sub runrtspserver { } $pid2 = $pid3; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $rtsppid port $port\n"; } @@ -2181,7 +2180,7 @@ sub runrtspserver { # Start the ssh (scp/sftp) server # sub runsshserver { - my ($id, $verbose, $ipv6) = @_; + my ($id, $verb, $ipv6) = @_; my $ip=$HOSTIP; my $proto = 'ssh'; my $ipvnum = 4; @@ -2222,7 +2221,7 @@ sub runsshserver { $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); my $flags = ""; - $flags .= "--verbose " if($verbose); + $flags .= "--verbose " if($verb); $flags .= "--debugprotocol " if($debugprotocol); $flags .= "--pidfile \"$pidfile\" "; $flags .= "--id $idnum " if($idnum > 1); @@ -2300,7 +2299,7 @@ sub runsshserver { { my $msg = "Fatal: $srvrname pubkey md5 missing : \"$hstpubmd5f\" : $!"; logmsg "$msg\n"; - stopservers($verbose); + stopservers($verb); die $msg; } @@ -2311,11 +2310,11 @@ sub runsshserver { { my $msg = "Fatal: $srvrname pubkey sha256 missing : \"$hstpubsha256f\" : $!"; logmsg "$msg\n"; - stopservers($verbose); + stopservers($verb); die $msg; } - logmsg "RUN: $srvrname on PID $pid2 port $wport\n" if($verbose); + logmsg "RUN: $srvrname on PID $pid2 port $wport\n" if($verb); return ($pid2, $sshpid, $wport); } @@ -2324,7 +2323,7 @@ sub runsshserver { # Start the MQTT server # sub runmqttserver { - my ($id, $verbose, $ipv6) = @_; + my ($id, $verb, $ipv6) = @_; my $ip=$HOSTIP; my $proto = 'mqtt'; my $port = protoport($proto); @@ -2375,7 +2374,7 @@ sub runmqttserver { my $mqttport = pidfromfile($portfile); $PORT{"mqtt"} = $mqttport; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server is now running PID $pid2 on PORT $mqttport\n"; } @@ -2386,7 +2385,7 @@ sub runmqttserver { # Start the socks server # sub runsocksserver { - my ($id, $verbose, $ipv6, $is_unix) = @_; + my ($id, $verb, $ipv6, $is_unix) = @_; my $ip=$HOSTIP; my $proto = 'socks'; my $ipvnum = 4; @@ -2445,7 +2444,7 @@ sub runsocksserver { my $port = pidfromfile($portfile); - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server is now running PID $pid2\n"; } @@ -2456,7 +2455,7 @@ sub runsocksserver { # start the dict server # sub rundictserver { - my ($verbose, $alt) = @_; + my ($verb, $alt) = @_; my $proto = "dict"; my $ip = $HOSTIP; my $ipvnum = 4; @@ -2514,7 +2513,7 @@ sub rundictserver { } $doesntrun{$pidfile} = 0; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $dictpid port $port\n"; } last; @@ -2528,7 +2527,7 @@ sub rundictserver { # start the SMB server # sub runsmbserver { - my ($verbose, $alt) = @_; + my ($verb, $alt) = @_; my $proto = "smb"; my $ip = $HOSTIP; my $ipvnum = 4; @@ -2586,7 +2585,7 @@ sub runsmbserver { } $doesntrun{$pidfile} = 0; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $smbpid port $port\n"; } last; @@ -2600,7 +2599,7 @@ sub runsmbserver { # start the telnet server # sub runnegtelnetserver { - my ($verbose, $alt) = @_; + my ($verb, $alt) = @_; my $proto = "telnet"; my $ip = $HOSTIP; my $ipvnum = 4; @@ -2657,7 +2656,7 @@ sub runnegtelnetserver { } $doesntrun{$pidfile} = 0; - if($verbose) { + if($verb) { logmsg "RUN: $srvrname server PID $ntelpid port $port\n"; } last; @@ -2673,7 +2672,7 @@ sub runnegtelnetserver { # be used to verify that a server present in %run hash is still functional # sub responsive_http_server { - my ($proto, $verbose, $alt, $port_or_path) = @_; + my ($proto, $verb, $alt, $port_or_path) = @_; my $ip = $HOSTIP; my $ipvnum = 4; my $idnum = 1; @@ -2699,7 +2698,7 @@ sub responsive_http_server { # used to verify that a server present in %run hash is still functional # sub responsive_pingpong_server { - my ($proto, $id, $verbose, $ipv6) = @_; + my ($proto, $id, $verb, $ipv6) = @_; my $port; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; @@ -2722,7 +2721,7 @@ sub responsive_pingpong_server { # used to verify that a server present in %run hash is still functional # sub responsive_rtsp_server { - my ($verbose, $ipv6) = @_; + my ($verb, $ipv6) = @_; my $proto = 'rtsp'; my $port = protoport($proto); my $ip = $HOSTIP; @@ -2744,7 +2743,7 @@ sub responsive_rtsp_server { # used to verify that a server present in %run hash is still functional # sub responsive_tftp_server { - my ($id, $verbose, $ipv6) = @_; + my ($id, $verb, $ipv6) = @_; my $proto = 'tftp'; my $port = protoport($proto); my $ip = $HOSTIP; @@ -2767,7 +2766,7 @@ sub responsive_tftp_server { # server present in %run hash is still functional # sub responsive_httptls_server { - my ($verbose, $ipv6) = @_; + my ($verb, $ipv6) = @_; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; my $proto = "httptls"; my $port = protoport($proto); @@ -2797,8 +2796,8 @@ sub clearlocks { $handle = "handle64.exe"; } my @handles = `$handle $dir -accepteula -nobanner`; - for $handle (@handles) { - if($handle =~ /^(\S+)\s+pid:\s+(\d+)\s+type:\s+(\w+)\s+([0-9A-F]+):\s+(.+)\r\r/) { + for my $tryhandle (@handles) { + if($tryhandle =~ /^(\S+)\s+pid:\s+(\d+)\s+type:\s+(\w+)\s+([0-9A-F]+):\s+(.+)\r\r/) { logmsg "Found $3 lock of '$5' ($4) by $1 ($2)\n"; # Ignore stunnel since we cannot do anything about its locks if("$3" eq "File" && "$1" ne "tstunnel.exe") { @@ -2905,7 +2904,7 @@ sub checksystemfeatures { close(DISABLED); if($disabled[0]) { - map s/[\r\n]//g, @disabled; + s/[\r\n]//g for @disabled; $dis = join(", ", @disabled); } @@ -2915,8 +2914,8 @@ sub checksystemfeatures { if($_ =~ /^curl ([^ ]*)/) { $curl = $_; - $VERSION = $1; - $curl =~ s/^(.*)(libcurl.*)/$1/g; + $CURLVERSION = $1; + $curl =~ s/^(.*)(libcurl.*)/$1/g || die "Failure determining curl binary version"; $libcurl = $2; if($curl =~ /linux|bsd|solaris/) { @@ -3334,7 +3333,7 @@ sub subVariables { $$thing =~ s/${prefix}CURL/$CURL/g; $$thing =~ s/${prefix}PWD/$pwd/g; $$thing =~ s/${prefix}POSIX_PWD/$posix_pwd/g; - $$thing =~ s/${prefix}VERSION/$VERSION/g; + $$thing =~ s/${prefix}VERSION/$CURLVERSION/g; $$thing =~ s/${prefix}TESTNUMBER/$testnum/g; my $file_pwd = $pwd; @@ -3717,7 +3716,6 @@ sub singletest_shouldrun { my @info_keywords = getpart("info", "keywords"); if(!$why) { my $match; - my $k; # Clear the list of keywords from the last test %keywords = (); @@ -3726,7 +3724,7 @@ sub singletest_shouldrun { $why = "missing the section!"; } - for $k (@info_keywords) { + for my $k (@info_keywords) { chomp $k; if ($disabled_keywords{lc($k)}) { $why = "disabled by keyword"; @@ -3815,11 +3813,11 @@ sub singletest_preprocess { @entiretest = prepro($testnum, @entiretest); # save the new version - open(D, ">$otest"); + open(D, ">$otest") || die "Failure writing test file"; foreach my $bytes (@entiretest) { print D pack('a*', $bytes) or die "Failed to print '$bytes': $!"; } - close(D); + close(D) || die "Failure writing test file"; # in case the process changed the file, reload it loadtest("log/test${testnum}"); @@ -3830,31 +3828,29 @@ sub singletest_preprocess { # Set up the test environment to run this test case sub singletest_setenv { my @setenv = getpart("client", "setenv"); - if(@setenv) { - foreach my $s (@setenv) { - chomp $s; - if($s =~ /([^=]*)=(.*)/) { - my ($var, $content) = ($1, $2); - # remember current setting, to restore it once test runs - $oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset'; - # set new value - if(!$content) { - delete $ENV{$var} if($ENV{$var}); - } - else { - if($var =~ /^LD_PRELOAD/) { - if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) { - # print "Skipping LD_PRELOAD due to lack of OS support\n"; - next; - } - if($feature{"debug"} || !$has_shared) { - # print "Skipping LD_PRELOAD due to no release shared build\n"; - next; - } + foreach my $s (@setenv) { + chomp $s; + if($s =~ /([^=]*)=(.*)/) { + my ($var, $content) = ($1, $2); + # remember current setting, to restore it once test runs + $oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset'; + # set new value + if(!$content) { + delete $ENV{$var} if($ENV{$var}); + } + else { + if($var =~ /^LD_PRELOAD/) { + if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) { + # print "Skipping LD_PRELOAD due to lack of OS support\n"; + next; + } + if($feature{"debug"} || !$has_shared) { + # print "Skipping LD_PRELOAD due to no release shared build\n"; + next; } - $ENV{$var} = "$content"; - print "setenv $var = $content\n" if($verbose); } + $ENV{$var} = "$content"; + print "setenv $var = $content\n" if($verbose); } } } @@ -4125,7 +4121,7 @@ sub singletest_run { my %hash = getpartattr("client", "stdin"); if($hash{'nonewline'}) { # cut off the final newline from the final line of the stdin data - chomp($stdintest[$#stdintest]); + chomp($stdintest[-1]); } writearray($stdinfile, \@stdintest); @@ -4154,20 +4150,20 @@ sub singletest_run { logmsg "$CMDLINE\n"; } - open(CMDLOG, ">", "$LOGDIR/$CURLLOG"); + open(CMDLOG, ">", "$LOGDIR/$CURLLOG") || die "Failure writing log file"; print CMDLOG "$CMDLINE\n"; - close(CMDLOG); + close(CMDLOG) || die "Failure writing log file"; my $dumped_core; my $cmdres; if($gdbthis) { my $gdbinit = "$TESTDIR/gdbinit$testnum"; - open(GDBCMD, ">$LOGDIR/gdbcmd"); + open(GDBCMD, ">$LOGDIR/gdbcmd") || die "Failure writing gdb file"; print GDBCMD "set args $cmdargs\n"; print GDBCMD "show args\n"; print GDBCMD "source $gdbinit\n" if -e $gdbinit; - close(GDBCMD); + close(GDBCMD) || die "Failure writing gdb file"; } # Flush output. @@ -4215,9 +4211,9 @@ sub singletest_clean { logmsg "core dumped\n"; if(0 && $gdb) { logmsg "running gdb for post-mortem analysis:\n"; - open(GDBCMD, ">$LOGDIR/gdbcmd2"); + open(GDBCMD, ">$LOGDIR/gdbcmd2") || die "Failure writing gdb file"; print GDBCMD "bt\n"; - close(GDBCMD); + close(GDBCMD) || die "Failure writing gdb file"; runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch $DBGCURL core "); # unlink("$LOGDIR/gdbcmd2"); } @@ -4354,20 +4350,20 @@ sub singletest_check { my $filemode=$hash{'mode'}; if($filemode && ($filemode eq "text") && $has_textaware) { # text mode when running on windows: fix line endings - map s/\r\n/\n/g, @validstdout; - map s/\n/\r\n/g, @validstdout; + s/\r\n/\n/g for @validstdout; + s/\n/\r\n/g for @validstdout; } if($hash{'nonewline'}) { # Yes, we must cut off the final newline from the final line # of the protocol data - chomp($validstdout[$#validstdout]); + chomp($validstdout[-1]); } if($hash{'crlf'} || ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { - map subNewlines(0, \$_), @validstdout; + subNewlines(0, \$_) for @validstdout; } $res = compare($testnum, $testname, "stdout", \@actual, \@validstdout); @@ -4408,18 +4404,18 @@ sub singletest_check { # text mode check in hyper-mode. Sometimes necessary if the stderr # data *looks* like HTTP and thus has gotten CRLF newlines # mistakenly - map s/\r\n/\n/g, @validstderr; + s/\r\n/\n/g for @validstderr; } if($filemode && ($filemode eq "text") && $has_textaware) { # text mode when running on windows: fix line endings - map s/\r\n/\n/g, @validstderr; - map s/\n/\r\n/g, @validstderr; + s/\r\n/\n/g for @validstderr; + s/\n/\r\n/g for @validstderr; } if($hash{'nonewline'}) { # Yes, we must cut off the final newline from the final line # of the protocol data - chomp($validstderr[$#validstderr]); + chomp($validstderr[-1]); } $res = compare($testnum, $testname, "stderr", \@actual, \@validstderr); @@ -4450,7 +4446,7 @@ sub singletest_check { if($hash{'nonewline'}) { # Yes, we must cut off the final newline from the final line # of the protocol data - chomp($protocol[$#protocol]); + chomp($protocol[-1]); } for(@strip) { @@ -4460,9 +4456,7 @@ sub singletest_check { @protocol= striparray( $_, \@protocol); } - my $strip; - - for $strip (@strippart) { + for my $strip (@strippart) { chomp $strip; for(@out) { eval $strip; @@ -4470,7 +4464,7 @@ sub singletest_check { } if($hash{'crlf'}) { - map subNewlines(1, \$_), @protocol; + subNewlines(1, \$_) for @protocol; } if((!$out[0] || ($out[0] eq "")) && $protocol[0]) { @@ -4503,18 +4497,18 @@ sub singletest_check { my $filemode=$replycheckpartattr{'mode'}; if($filemode && ($filemode eq "text") && $has_textaware) { # text mode when running on windows: fix line endings - map s/\r\n/\n/g, @replycheckpart; - map s/\n/\r\n/g, @replycheckpart; + s/\r\n/\n/g for @replycheckpart; + s/\n/\r\n/g for @replycheckpart; } if($replycheckpartattr{'nonewline'}) { # Yes, we must cut off the final newline from the final line # of the datacheck - chomp($replycheckpart[$#replycheckpart]); + chomp($replycheckpart[-1]); } if($replycheckpartattr{'crlf'} || ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { - map subNewlines(0, \$_), @replycheckpart; + subNewlines(0, \$_) for @replycheckpart; } push(@reply, @replycheckpart); } @@ -4526,20 +4520,20 @@ sub singletest_check { if(@reply) { if($replyattr{'nonewline'}) { # cut off the final newline from the final line of the data - chomp($reply[$#reply]); + chomp($reply[-1]); } } # get the mode attribute my $filemode=$replyattr{'mode'}; if($filemode && ($filemode eq "text") && $has_textaware) { # text mode when running on windows: fix line endings - map s/\r\n/\n/g, @reply; - map s/\n/\r\n/g, @reply; + s/\r\n/\n/g for @reply; + s/\n/\r\n/g for @reply; } if($replyattr{'crlf'} || ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { - map subNewlines(0, \$_), @reply; + subNewlines(0, \$_) for @reply; } } @@ -4562,13 +4556,12 @@ sub singletest_check { my %hash = getpartattr("verify", "upload"); if($hash{'nonewline'}) { # cut off the final newline from the final line of the upload data - chomp($upload[$#upload]); + chomp($upload[-1]); } # verify uploaded data my @out = loadarray("$LOGDIR/upload.$testnum"); - my $strip; - for $strip (@strippart) { + for my $strip (@strippart) { chomp $strip; for(@out) { eval $strip; @@ -4595,7 +4588,7 @@ sub singletest_check { if($hash{'nonewline'}) { # Yes, we must cut off the final newline from the final line # of the protocol data - chomp($proxyprot[$#proxyprot]); + chomp($proxyprot[-1]); } my @out = loadarray($PROXYIN); @@ -4606,8 +4599,7 @@ sub singletest_check { @proxyprot= striparray( $_, \@proxyprot); } - my $strip; - for $strip (@strippart) { + for my $strip (@strippart) { chomp $strip; for(@out) { eval $strip; @@ -4616,7 +4608,7 @@ sub singletest_check { if($hash{'crlf'} || ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { - map subNewlines(0, \$_), @proxyprot; + subNewlines(0, \$_) for @proxyprot; } $res = compare($testnum, $testname, "proxy", \@out, \@proxyprot); @@ -4650,22 +4642,21 @@ sub singletest_check { my @generated=loadarray($filename); # what parts to cut off from the file - my @stripfile = getpart("verify", "stripfile".$partsuffix); + my @stripfilepar = getpart("verify", "stripfile".$partsuffix); my $filemode=$hash{'mode'}; if($filemode && ($filemode eq "text") && $has_textaware) { # text mode when running on windows: fix line endings - map s/\r\n/\n/g, @outfile; - map s/\n/\r\n/g, @outfile; + s/\r\n/\n/g for @outfile; + s/\n/\r\n/g for @outfile; } if($hash{'crlf'} || ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { - map subNewlines(0, \$_), @outfile; + subNewlines(0, \$_) for @outfile; } - my $strip; - for $strip (@stripfile) { + for my $strip (@stripfilepar) { chomp $strip; my @newgen; for(@generated) { @@ -4761,7 +4752,7 @@ sub singletest_check { if($valgrind) { if(use_valgrind() && !$disablevalgrind) { - unless(opendir(DIR, "$LOGDIR")) { + if(!opendir(DIR, "$LOGDIR")) { logmsg "ERROR: unable to read $LOGDIR\n"; # timestamp test result verification end $timevrfyend{$testnum} = Time::HiRes::time(); @@ -4827,7 +4818,7 @@ sub singletest_success { my $sofar= time()-$start; my $esttotal = $sofar/$count * $total; my $estleft = $esttotal - $sofar; - my $left=sprintf("remaining: %02d:%02d", + my $timeleft=sprintf("remaining: %02d:%02d", $estleft/60, $estleft%60); my $took = $timevrfyend{$testnum} - $timeprepini{$testnum}; @@ -4835,7 +4826,7 @@ sub singletest_success { $sofar/60, $sofar%60); if(!$automakestyle) { logmsg sprintf("OK (%-3d out of %-3d, %s, took %.3fs, %s)\n", - $count, $total, $left, $took, $duration); + $count, $total, $timeleft, $took, $duration); } else { my $testname= (getpart("client", "name"))[0]; @@ -4958,18 +4949,18 @@ sub singletest { # Stop all running test servers # sub stopservers { - my $verbose = $_[0]; + my $verb = $_[0]; # # kill sockfilter processes for all pingpong servers # - killallsockfilters($verbose); + killallsockfilters($verb); # # kill all server pids from %run hash clearing them # my $pidlist; foreach my $server (keys %run) { if($run{$server}) { - if($verbose) { + if($verb) { my $prev = 0; my $pids = $run{$server}; foreach my $pid (split(' ', $pids)) { @@ -4985,7 +4976,7 @@ sub stopservers { } $runcert{$server} = 0 if($runcert{$server}); } - killpid($verbose, $pidlist); + killpid($verb, $pidlist); # # cleanup all server pid files # @@ -5002,7 +4993,7 @@ sub stopservers { logmsg "Warning: "; } logmsg "$server server unexpectedly alive\n"; - killpid($verbose, $pid); + killpid($verb, $pid); } unlink($pidfile) if(-f $pidfile); } @@ -5795,7 +5786,7 @@ while(@ARGV) { die "Unsupported type: $type\n" if($type !~ /^keyword|test|tool$/); foreach my $pattern (split(/,/, $patterns)) { - if($type =~ /^test$/) { + if($type eq "test") { # Strip leading zeros in the test number $pattern = int($pattern); } @@ -5929,7 +5920,7 @@ while(@ARGV) { } elsif(($ARGV[0] eq "-h") || ($ARGV[0] eq "--help")) { # show help text - print < 1000; } } + close(SINGLE); if(@tail) { my $tailshow = 200; my $tailskip = 0; @@ -6255,7 +6247,6 @@ sub displaylogcontent { logmsg "$tail[$_]"; } } - close(SINGLE); } } @@ -6304,7 +6295,7 @@ sub displaylogs { if(($log =~ /^trace\d+/) && ($log !~ /^trace$testnum/)) { next; # skip traceNnn of other tests } - if(($log =~ /^valgrind\d+/) && ($log !~ /^valgrind$testnum(\..*|)$/)) { + if(($log =~ /^valgrind\d+/) && ($log !~ /^valgrind$testnum(?:\..*)?$/)) { next; # skip valgrindNnn of other tests } if(($log =~ /^test$testnum$/)) { @@ -6326,7 +6317,6 @@ citest_starttestrun(); my $failed; my $failedign; -my $testnum; my $ok=0; my $ign=0; my $total=0; @@ -6336,7 +6326,7 @@ my $count=0; $start = time(); -foreach $testnum (@at) { +foreach my $testnum (@at) { $lasttest = $testnum if($testnum > $lasttest); $count++; diff --git a/tests/serverhelp.pm b/tests/serverhelp.pm index b5b34564d4..3b9831777e 100644 --- a/tests/serverhelp.pm +++ b/tests/serverhelp.pm @@ -26,14 +26,11 @@ package serverhelp; use strict; use warnings; -use Exporter; - #*************************************************************************** # Global symbols allowed without explicit package name # use vars qw( - @ISA @EXPORT_OK ); @@ -41,7 +38,7 @@ use vars qw( #*************************************************************************** # Inherit Exporter's capabilities # -@ISA = qw(Exporter); +use base qw(Exporter); #*************************************************************************** @@ -118,7 +115,7 @@ sub servername_str { $idnum = 1 if(not $idnum); die "unsupported ID number: '$idnum'" unless($idnum && ($idnum =~ /^(\d+)$/)); - $idnum = '' unless($idnum > 1); + $idnum = '' if($idnum <= 1); return "${proto}${idnum}${ipver}"; } diff --git a/tests/sshhelp.pm b/tests/sshhelp.pm index e2e1e5eb96..7b7fb3e408 100644 --- a/tests/sshhelp.pm +++ b/tests/sshhelp.pm @@ -26,7 +26,6 @@ package sshhelp; use strict; use warnings; -use Exporter; use File::Spec; @@ -34,7 +33,6 @@ use File::Spec; # Global symbols allowed without explicit package name # use vars qw( - @ISA @EXPORT_OK $sshdexe $sshexe @@ -64,7 +62,7 @@ use vars qw( #*************************************************************************** # Inherit Exporter's capabilities # -@ISA = qw(Exporter); +use base qw(Exporter); #*************************************************************************** @@ -214,7 +212,7 @@ sub dump_array { } elsif(open(TEXTFH, ">$filename")) { foreach my $line (@arr) { - $line .= "\n" unless($line =~ /\n$/); + $line .= "\n" if($line !~ /\n$/); print TEXTFH $line; } if(!close(TEXTFH)) { @@ -319,6 +317,7 @@ sub find_file { return $file; } } + return ""; } @@ -337,6 +336,7 @@ sub find_exe_file { return $file if(($xext) && (lc($file) =~ /\Q$xext\E$/)); } } + return ""; } @@ -420,6 +420,7 @@ sub find_httptlssrv { } return $p if($found); } + return ""; } diff --git a/tests/valgrind.pm b/tests/valgrind.pm index b32e2e9849..0e8e99d699 100644 --- a/tests/valgrind.pm +++ b/tests/valgrind.pm @@ -22,6 +22,9 @@ # ########################################################################### +use strict; +use warnings; + use File::Basename; sub valgrindparse {