luo980/curl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tests: silence some Perl::Critic warnings in test suite

Browse Source 
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
This commit is contained in:
Dan Fandrich 2023-03-27 19:58:00 -07:00
parent b5cb9a5a36
commit b133f70a52
7 changed files with 186 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
tests/ftp.pm
View File

@ -22,6 +22,9 @@
# #
########################################################################### ###########################################################################
use strict;
use warnings;
BEGIN { BEGIN {
# portable sleeping needs Time::HiRes # portable sleeping needs Time::HiRes
eval { eval {
@ -35,9 +38,6 @@ BEGIN {
} }
} }
use strict;
use warnings;
use serverhelp qw( use serverhelp qw(
servername_id servername_id
mainsockf_pidfilename mainsockf_pidfilename
@ -82,7 +82,7 @@ sub pidfromfile {
if(-f $pidfile && -s $pidfile && open(PIDFH, "<$pidfile")) { if(-f $pidfile && -s $pidfile && open(PIDFH, "<$pidfile")) {
$pid = 0 + <PIDFH>; $pid = 0 + <PIDFH>;
close(PIDFH); close(PIDFH);
$pid = 0 unless($pid > 0); $pid = 0 if($pid < 0);
} }
return $pid; return $pid;
} }
@ -230,8 +230,8 @@ sub processexists {
# with a SIGTERM signal and SIGKILLs those which haven't died on time. # with a SIGTERM signal and SIGKILLs those which haven't died on time.
# #
sub killpid { sub killpid {
use POSIX ":sys_wait_h";
my ($verbose, $pidlist) = @_; my ($verbose, $pidlist) = @_;
use POSIX ":sys_wait_h";
my @requested; my @requested;
my @signalled; my @signalled;
my @reapchild; my @reapchild;
@ -380,8 +380,7 @@ sub killallsockfilters {
sub set_advisor_read_lock { sub set_advisor_read_lock {
my ($filename) = @_; my ($filename) = @_;
if(open(FILEH, ">$filename")) { if(open(FILEH, ">$filename") && close(FILEH)) {
close(FILEH);
return; return;
} }
printf "Error creating lock file $filename error: $!"; printf "Error creating lock file $filename error: $!";

15
tests/getpart.pm
View File

@ -22,7 +22,8 @@
# #
########################################################################### ###########################################################################
#use strict; use strict;
use warnings;
use Memoize; use Memoize;
use MIME::Base64; use MIME::Base64;
@ -309,12 +310,12 @@ sub compareparts {
sub writearray { sub writearray {
my ($filename, $arrayref)=@_; my ($filename, $arrayref)=@_;
open(TEMP, ">$filename"); open(TEMP, ">$filename") || die "Failure writing file";
binmode(TEMP,":raw"); # cygwin fix by Kevin Roth binmode(TEMP,":raw"); # cygwin fix by Kevin Roth
for(@$arrayref) { for(@$arrayref) {
print TEMP $_; print TEMP $_;
} }
close(TEMP); close(TEMP) || die "Failure writing file";
} }
# #
@ -341,7 +342,7 @@ sub showdiff {
my $file1="$logdir/check-generated"; my $file1="$logdir/check-generated";
my $file2="$logdir/check-expected"; my $file2="$logdir/check-expected";
open(TEMP, ">$file1"); open(TEMP, ">$file1") || die "Failure writing diff file";
for(@$firstref) { for(@$firstref) {
my $l = $_; my $l = $_;
$l =~ s/\r/[CR]/g; $l =~ s/\r/[CR]/g;
@ -350,9 +351,9 @@ sub showdiff {
print TEMP $l; print TEMP $l;
print TEMP "\n"; 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) { for(@$secondref) {
my $l = $_; my $l = $_;
$l =~ s/\r/[CR]/g; $l =~ s/\r/[CR]/g;
@ -361,7 +362,7 @@ sub showdiff {
print TEMP $l; print TEMP $l;
print TEMP "\n"; print TEMP "\n";
} }
close(TEMP); close(TEMP) || die "Failure writing diff file";
my @out = `diff -u $file2 $file1 2>/dev/null`; my @out = `diff -u $file2 $file1 2>/dev/null`;
if(!$out[0]) { if(!$out[0]) {

52
tests/pathhelp.pm
View File

@ -56,9 +56,7 @@ use warnings;
use Cwd 'abs_path'; use Cwd 'abs_path';
BEGIN { BEGIN {
require Exporter; use base qw(Exporter);
our @ISA = qw(Exporter);
our @EXPORT = qw( our @EXPORT = qw(
sys_native_abs_path 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. # Returns boolean true if 'cygpath' utility should be used for path conversion.
sub should_use_cygpath { sub should_use_cygpath {
unless (os_is_win()) { if(!os_is_win()) {
$use_cygpath = 0; $use_cygpath = 0;
return 0; return 0;
} }
@ -134,7 +132,7 @@ sub normalize_path;
# Returns current working directory in Win32 format on Windows. # Returns current working directory in Win32 format on Windows.
# #
sub sys_native_current_path { sub sys_native_current_path {
return Cwd::getcwd() unless os_is_win(); return Cwd::getcwd() if !os_is_win();
my $cur_dir; my $cur_dir;
if($^O eq 'msys') { if($^O eq 'msys') {
@ -203,7 +201,7 @@ sub sys_native_path {
my ($path) = @_; my ($path) = @_;
# Return untouched on non-Windows platforms. # Return untouched on non-Windows platforms.
return $path unless (os_is_win()); return $path if (!os_is_win());
# Do not process empty path. # Do not process empty path.
return $path if ($path eq ''); return $path if ($path eq '');
@ -233,7 +231,7 @@ sub sys_native_path {
# Convert leading slash back to forward slash to indicate # Convert leading slash back to forward slash to indicate
# directory on Win32 current drive or capitalize drive letter. # directory on Win32 current drive or capitalize drive letter.
substr($path, 0, 1) = $first_char; substr($path, 0, 1, $first_char);
return $path; return $path;
} }
elsif(should_use_cygpath()) { elsif(should_use_cygpath()) {
@ -266,7 +264,7 @@ sub sys_native_path {
# program parameters if program is not Msys-based. # program parameters if program is not Msys-based.
$path = do_msys_transform($path); $path = do_msys_transform($path);
return undef unless defined $path; return undef if !defined $path;
# Capitalize drive letter for Win32 paths. # Capitalize drive letter for Win32 paths.
$path =~ s{^([a-z]:)}{\u$1}; $path =~ s{^([a-z]:)}{\u$1};
@ -303,7 +301,7 @@ sub sys_native_path {
sub sys_native_abs_path { sub sys_native_abs_path {
my ($path) = @_; my ($path) = @_;
unless(os_is_win()) { if(!os_is_win()) {
# Convert path to absolute form. # Convert path to absolute form.
$path = Cwd::abs_path($path); $path = Cwd::abs_path($path);
@ -362,7 +360,7 @@ sub sys_native_abs_path {
# Path is directory or filename on Win32 current drive. ('\Windows') # Path is directory or filename on Win32 current drive. ('\Windows')
my $w32drive = get_win32_current_drive(); my $w32drive = get_win32_current_drive();
return undef unless defined $w32drive; return undef if !defined $w32drive;
# Combine drive and path. # Combine drive and path.
# Replace any possible back slashes with forward slashes, # Replace any possible back slashes with forward slashes,
@ -370,7 +368,7 @@ sub sys_native_abs_path {
return normalize_path($w32drive . $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 # Path is in relative form. Resolve relative directories in Unix form
# *BEFORE* converting to Win32 form otherwise paths like # *BEFORE* converting to Win32 form otherwise paths like
# '../../../cygdrive/c/windows' will not be resolved. # '../../../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 # Msys transforms automatically path to Windows native form in staring
# program parameters if program is not Msys-based. # program parameters if program is not Msys-based.
$path = do_msys_transform($path); $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. # Replace any back and duplicated slashes with single forward slashes.
$path =~ s{[\\/]+}{/}g; $path =~ s{[\\/]+}{/}g;
@ -423,7 +421,7 @@ sub simple_transform_win32_to_unix;
sub build_sys_abs_path { sub build_sys_abs_path {
my ($path) = @_; my ($path) = @_;
unless(os_is_win()) { if(!os_is_win()) {
# Convert path to absolute form. # Convert path to absolute form.
$path = Cwd::abs_path($path); $path = Cwd::abs_path($path);
@ -442,7 +440,7 @@ sub build_sys_abs_path {
# Replace any possible back slashes with forward slashes, # Replace any possible back slashes with forward slashes,
# remove any duplicated slashes. # remove any duplicated slashes.
$path = get_abs_path_on_win32_drive($1, $2); $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); return simple_transform_win32_to_unix($path);
} }
@ -475,7 +473,7 @@ sub build_sys_abs_path {
# Unix-style paths. # Unix-style paths.
# Remove duplicated slashes, as they may be not processed. # Remove duplicated slashes, as they may be not processed.
$path = normalize_path($path); $path = normalize_path($path);
return undef unless defined $path; return undef if !defined $path;
# Use 'cygpath', '-u' means Unix-stile path, # Use 'cygpath', '-u' means Unix-stile path,
# '-a' means absolute path # '-a' means absolute path
@ -500,7 +498,7 @@ sub build_sys_abs_path {
# Replace any possible back slashes with forward slashes, # Replace any possible back slashes with forward slashes,
# remove any duplicated slashes. # remove any duplicated slashes.
$path = normalize_path($path); $path = normalize_path($path);
return undef unless defined $path; return undef if !defined $path;
return simple_transform_win32_to_unix($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') # Path is directory or filename on Win32 current drive. ('\Windows')
my $w32drive = get_win32_current_drive(); my $w32drive = get_win32_current_drive();
return undef unless defined $w32drive; return undef if !defined $w32drive;
# Combine drive and path. # Combine drive and path.
# Resolve relative dirs in Win32-style path or paths like 'D:/../c/' # 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, # Replace any possible back slashes with forward slashes,
# remove any duplicated slashes. # remove any duplicated slashes.
$path = normalize_path($w32drive . $path); $path = normalize_path($w32drive . $path);
return undef unless defined $path; return undef if !defined $path;
return simple_transform_win32_to_unix($path); return simple_transform_win32_to_unix($path);
} }
# Path is not in any Win32 form. # 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 # Path in relative form. Resolve relative directories in Unix form
# *BEFORE* converting to Win32 form otherwise paths like # *BEFORE* converting to Win32 form otherwise paths like
# '../../../cygdrive/c/windows' will not be resolved. # '../../../cygdrive/c/windows' will not be resolved.
@ -561,12 +559,12 @@ sub normalize_path {
# Don't process empty paths. # Don't process empty paths.
return $path if $path eq ''; return $path if $path eq '';
unless($path =~ m{(?:^|\\|/)\.{1,2}(?:\\|/|$)}) { if($path !~ m{(?:^|\\|/)\.{1,2}(?:\\|/|$)}) {
# Speed up processing of simple paths. # Speed up processing of simple paths.
my $first_char = substr($path, 0, 1); my $first_char = substr($path, 0, 1);
$path =~ s{[\\/]+}{/}g; $path =~ s{[\\/]+}{/}g;
# Restore starting backslash if any. # Restore starting backslash if any.
substr($path, 0, 1) = $first_char; substr($path, 0, 1, $first_char);
return $path; return $path;
} }
@ -581,7 +579,7 @@ sub normalize_path {
# Process path separately from drive letter. # Process path separately from drive letter.
@arr = split(m{\/|\\}, $3); @arr = split(m{\/|\\}, $3);
# Replace backslash with forward slash if required. # Replace backslash with forward slash if required.
substr($prefix, 2, 1) = '/' if $have_root; substr($prefix, 2, 1, '/') if $have_root;
} }
else { else {
if($path =~ m{^(\/|\\)}) { if($path =~ m{^(\/|\\)}) {
@ -601,7 +599,7 @@ sub normalize_path {
if(length($el) == 0 || $el eq '.') { if(length($el) == 0 || $el eq '.') {
next; next;
} }
elsif($el eq '..' && @res > 0 && $res[$#res] ne '..') { elsif($el eq '..' && @res > 0 && $res[-1] ne '..') {
pop @res; pop @res;
next; next;
} }
@ -717,7 +715,7 @@ sub do_dumb_guessed_transform {
# '/bin/' can be mapped to '/usr/bin/'. # '/bin/' can be mapped to '/usr/bin/'.
my $check_path = $path; my $check_path = $path;
my $path_tail = ''; my $path_tail = '';
do { while(1) {
if(-d $check_path) { if(-d $check_path) {
my $res = my $res =
`(cd "$check_path" && cmd /c "echo %__CD__%") 2>/dev/null`; `(cd "$check_path" && cmd /c "echo %__CD__%") 2>/dev/null`;
@ -732,7 +730,7 @@ sub do_dumb_guessed_transform {
return $res . $path_tail; return $res . $path_tail;
} }
else { else {
$res =~ s{/$}{} unless $check_path =~ m{/$}; $res =~ s{/$}{} if $check_path !~ m{/$};
return $res; return $res;
} }
} }
@ -747,7 +745,7 @@ sub do_dumb_guessed_transform {
warn "Can't determine Win32 directory for path \"$path\".\n"; warn "Can't determine Win32 directory for path \"$path\".\n";
return undef; return undef;
} }
} while(1); }
} }
@ -772,7 +770,7 @@ sub simple_transform_win32_to_unix {
} }
# 'cygpath' is not available, use guessed transformation. # '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 " . warn "Can't determine Unix-style directory for Win32 " .
"directory \"$path\".\n"; "directory \"$path\".\n";
return undef; return undef;

284
tests/runtests.pl
View File

@ -54,6 +54,10 @@
# fixed. As long as the -g option is never given, and the -n is always # fixed. As long as the -g option is never given, and the -n is always
# given, this won't be a problem. # 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: # 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 Cwd;
use Digest::MD5 qw(md5); use Digest::MD5 qw(md5);
use MIME::Base64; use MIME::Base64;
@ -121,11 +121,11 @@ use sshhelp qw(
use pathhelp; use pathhelp;
require "getpart.pm"; # array functions require getpart; # array functions
require "valgrind.pm"; # valgrind report parser require valgrind; # valgrind report parser
require "ftp.pm"; require ftp;
require "azure.pm"; require azure;
require "appveyor.pm"; require appveyor;
my $HOSTIP="127.0.0.1"; # address on which the test server listens my $HOSTIP="127.0.0.1"; # address on which the test server listens
my $HOST6IP="[::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 $SSHSRVMD5 = "[uninitialized]"; # MD5 of ssh server public key
my $SSHSRVSHA256 = "[uninitialized]"; # SHA256 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 $srcdir = $ENV{'srcdir'} || '.';
my $CURL="../src/curl".exe_ext('TOOL'); # what curl binary to run on the tests 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 # torture test variables
my $torture; my $torture;
my $tortnum;
my $tortalloc; my $tortalloc;
my $shallow; my $shallow;
my $randseed = 0; my $randseed = 0;
@ -334,8 +333,7 @@ $SIG{TERM} = \&catch_zap;
# Clear all possible '*_proxy' environment variables for various protocols # Clear all possible '*_proxy' environment variables for various protocols
# to prevent them to interfere with our testing! # to prevent them to interfere with our testing!
my $protocol; foreach my $protocol (('ftp', 'http', 'ftps', 'https', 'no', 'all')) {
foreach $protocol (('ftp', 'http', 'ftps', 'https', 'no', 'all')) {
my $proxy = "${protocol}_proxy"; my $proxy = "${protocol}_proxy";
# clear lowercase version # clear lowercase version
delete $ENV{$proxy} if($ENV{$proxy}); 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. # Check if a given child process has just died. Reaps it if so.
# #
sub checkdied { sub checkdied {
use POSIX ":sys_wait_h";
my $pid = $_[0]; my $pid = $_[0];
if((not defined $pid) || $pid <= 0) { if((not defined $pid) || $pid <= 0) {
return 0; return 0;
} }
use POSIX ":sys_wait_h";
my $rc = pidwait($pid, &WNOHANG); my $rc = pidwait($pid, &WNOHANG);
return ($rc == $pid)?1:0; return ($rc == $pid)?1:0;
} }
@ -464,7 +462,7 @@ sub startnew {
if ($fake) { if ($fake) {
if(open(OUT, ">$pidfile")) { if(open(OUT, ">$pidfile")) {
print OUT $child . "\n"; print OUT $child . "\n";
close(OUT); close(OUT) || die "Failure writing pidfile";
logmsg "startnew: $pidfile faked with pid=$child\n" if($verbose); logmsg "startnew: $pidfile faked with pid=$child\n" if($verbose);
} }
else { else {
@ -517,7 +515,7 @@ sub startnew {
# #
sub checkcmd { sub checkcmd {
my ($cmd)=@_; 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", "/sbin", "/usr/bin", "/usr/local/bin",
"$LIBDIR/.libs", "$LIBDIR"); "$LIBDIR/.libs", "$LIBDIR");
for(@paths) { for(@paths) {
@ -526,6 +524,7 @@ sub checkcmd {
return "$_/$cmd"; return "$_/$cmd";
} }
} }
return "";
} }
####################################################################### #######################################################################
@ -1032,7 +1031,7 @@ sub verifyrtsp {
logmsg "RUN: curl command returned $res\n"; logmsg "RUN: curl command returned $res\n";
if(open(FILE, "<$verifylog")) { if(open(FILE, "<$verifylog")) {
while(my $string = <FILE>) { while(my $string = <FILE>) {
logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); logmsg "RUN: $string" if($string !~ /^[ \t]*$/);
} }
close(FILE); close(FILE);
} }
@ -1445,7 +1444,7 @@ sub responsiveserver {
# start the http2 server # start the http2 server
# #
sub runhttp2server { sub runhttp2server {
my ($verbose) = @_; my ($verb) = @_;
my $server; my $server;
my $srvrname; my $srvrname;
my $pidfile; my $pidfile;
@ -1501,7 +1500,7 @@ sub runhttp2server {
} }
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $http2pid ". logmsg "RUN: $srvrname server PID $http2pid ".
"http-port $port https-port $port2 ". "http-port $port https-port $port2 ".
"backend $HOSTIP:" . protoport("http") . "\n"; "backend $HOSTIP:" . protoport("http") . "\n";
@ -1518,7 +1517,7 @@ sub runhttp2server {
# start the http3 server # start the http3 server
# #
sub runhttp3server { sub runhttp3server {
my ($verbose, $cert) = @_; my ($verb, $cert) = @_;
my $server; my $server;
my $srvrname; my $srvrname;
my $pidfile; my $pidfile;
@ -1573,7 +1572,7 @@ sub runhttp3server {
} }
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $http3pid port $port\n"; logmsg "RUN: $srvrname server PID $http3pid port $port\n";
} }
last; last;
@ -1588,7 +1587,7 @@ sub runhttp3server {
# start the http server # start the http server
# #
sub runhttpserver { sub runhttpserver {
my ($proto, $verbose, $alt, $port_or_path) = @_; my ($proto, $verb, $alt, $port_or_path) = @_;
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $ipvnum = 4; my $ipvnum = 4;
my $idnum = 1; my $idnum = 1;
@ -1677,7 +1676,7 @@ sub runhttpserver {
} }
$pid2 = $pid3; $pid2 = $pid3;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server is on PID $httppid port $port_or_path\n"; 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 # start the https stunnel based server
# #
sub runhttpsserver { sub runhttpsserver {
my ($verbose, $proto, $proxy, $certfile) = @_; my ($verb, $proto, $proxy, $certfile) = @_;
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $ipvnum = 4; my $ipvnum = 4;
my $idnum = 1; my $idnum = 1;
@ -1764,7 +1763,7 @@ sub runhttpsserver {
next; next;
} }
# we have a server! # we have a server!
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server is PID $httpspid port $port\n"; logmsg "RUN: $srvrname server is PID $httpspid port $port\n";
} }
last; last;
@ -1779,7 +1778,7 @@ sub runhttpsserver {
# start the non-stunnel HTTP TLS extensions capable server # start the non-stunnel HTTP TLS extensions capable server
# #
sub runhttptlsserver { sub runhttptlsserver {
my ($verbose, $ipv6) = @_; my ($verb, $ipv6) = @_;
my $proto = "httptls"; my $proto = "httptls";
my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
@ -1838,7 +1837,7 @@ sub runhttptlsserver {
} }
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $httptlspid port $port\n"; logmsg "RUN: $srvrname server PID $httptlspid port $port\n";
} }
last; last;
@ -1851,7 +1850,7 @@ sub runhttptlsserver {
# start the pingpong server (FTP, POP3, IMAP, SMTP) # start the pingpong server (FTP, POP3, IMAP, SMTP)
# #
sub runpingpongserver { sub runpingpongserver {
my ($proto, $id, $verbose, $ipv6) = @_; my ($proto, $id, $verb, $ipv6) = @_;
my $port; my $port;
my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
@ -1904,7 +1903,7 @@ sub runpingpongserver {
# where is it? # where is it?
$port = pidfromfile($portfile); $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. # Server is up. Verify that we can speak to it.
my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port);
@ -1918,7 +1917,7 @@ sub runpingpongserver {
} }
$pid2 = $pid3; $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! # Assign the correct port variable!
if($proto =~ /^(?:ftp|imap|pop3|smtp)$/) { if($proto =~ /^(?:ftp|imap|pop3|smtp)$/) {
@ -1936,7 +1935,7 @@ sub runpingpongserver {
# start the ftps/imaps/pop3s/smtps server (or rather, tunnel) # start the ftps/imaps/pop3s/smtps server (or rather, tunnel)
# #
sub runsecureserver { sub runsecureserver {
my ($verbose, $ipv6, $certfile, $proto, $clearport) = @_; my ($verb, $ipv6, $certfile, $proto, $clearport) = @_;
my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
my $idnum = 1; my $idnum = 1;
@ -2002,7 +2001,7 @@ sub runsecureserver {
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
$runcert{$server} = $certfile; $runcert{$server} = $certfile;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server is PID $protospid port $port\n"; logmsg "RUN: $srvrname server is PID $protospid port $port\n";
} }
last; last;
@ -2017,7 +2016,7 @@ sub runsecureserver {
# start the tftp server # start the tftp server
# #
sub runtftpserver { sub runtftpserver {
my ($id, $verbose, $ipv6) = @_; my ($id, $verb, $ipv6) = @_;
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $proto = 'tftp'; my $proto = 'tftp';
my $ipvnum = 4; my $ipvnum = 4;
@ -2087,7 +2086,7 @@ sub runtftpserver {
} }
$pid2 = $pid3; $pid2 = $pid3;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server on PID $tftppid port $port\n"; logmsg "RUN: $srvrname server on PID $tftppid port $port\n";
} }
@ -2099,7 +2098,7 @@ sub runtftpserver {
# start the rtsp server # start the rtsp server
# #
sub runrtspserver { sub runrtspserver {
my ($verbose, $ipv6) = @_; my ($verb, $ipv6) = @_;
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $proto = 'rtsp'; my $proto = 'rtsp';
my $ipvnum = 4; my $ipvnum = 4;
@ -2169,7 +2168,7 @@ sub runrtspserver {
} }
$pid2 = $pid3; $pid2 = $pid3;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $rtsppid port $port\n"; logmsg "RUN: $srvrname server PID $rtsppid port $port\n";
} }
@ -2181,7 +2180,7 @@ sub runrtspserver {
# Start the ssh (scp/sftp) server # Start the ssh (scp/sftp) server
# #
sub runsshserver { sub runsshserver {
my ($id, $verbose, $ipv6) = @_; my ($id, $verb, $ipv6) = @_;
my $ip=$HOSTIP; my $ip=$HOSTIP;
my $proto = 'ssh'; my $proto = 'ssh';
my $ipvnum = 4; my $ipvnum = 4;
@ -2222,7 +2221,7 @@ sub runsshserver {
$logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
my $flags = ""; my $flags = "";
$flags .= "--verbose " if($verbose); $flags .= "--verbose " if($verb);
$flags .= "--debugprotocol " if($debugprotocol); $flags .= "--debugprotocol " if($debugprotocol);
$flags .= "--pidfile \"$pidfile\" "; $flags .= "--pidfile \"$pidfile\" ";
$flags .= "--id $idnum " if($idnum > 1); $flags .= "--id $idnum " if($idnum > 1);
@ -2300,7 +2299,7 @@ sub runsshserver {
{ {
my $msg = "Fatal: $srvrname pubkey md5 missing : \"$hstpubmd5f\" : $!"; my $msg = "Fatal: $srvrname pubkey md5 missing : \"$hstpubmd5f\" : $!";
logmsg "$msg\n"; logmsg "$msg\n";
stopservers($verbose); stopservers($verb);
die $msg; die $msg;
} }
@ -2311,11 +2310,11 @@ sub runsshserver {
{ {
my $msg = "Fatal: $srvrname pubkey sha256 missing : \"$hstpubsha256f\" : $!"; my $msg = "Fatal: $srvrname pubkey sha256 missing : \"$hstpubsha256f\" : $!";
logmsg "$msg\n"; logmsg "$msg\n";
stopservers($verbose); stopservers($verb);
die $msg; 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); return ($pid2, $sshpid, $wport);
} }
@ -2324,7 +2323,7 @@ sub runsshserver {
# Start the MQTT server # Start the MQTT server
# #
sub runmqttserver { sub runmqttserver {
my ($id, $verbose, $ipv6) = @_; my ($id, $verb, $ipv6) = @_;
my $ip=$HOSTIP; my $ip=$HOSTIP;
my $proto = 'mqtt'; my $proto = 'mqtt';
my $port = protoport($proto); my $port = protoport($proto);
@ -2375,7 +2374,7 @@ sub runmqttserver {
my $mqttport = pidfromfile($portfile); my $mqttport = pidfromfile($portfile);
$PORT{"mqtt"} = $mqttport; $PORT{"mqtt"} = $mqttport;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server is now running PID $pid2 on PORT $mqttport\n"; logmsg "RUN: $srvrname server is now running PID $pid2 on PORT $mqttport\n";
} }
@ -2386,7 +2385,7 @@ sub runmqttserver {
# Start the socks server # Start the socks server
# #
sub runsocksserver { sub runsocksserver {
my ($id, $verbose, $ipv6, $is_unix) = @_; my ($id, $verb, $ipv6, $is_unix) = @_;
my $ip=$HOSTIP; my $ip=$HOSTIP;
my $proto = 'socks'; my $proto = 'socks';
my $ipvnum = 4; my $ipvnum = 4;
@ -2445,7 +2444,7 @@ sub runsocksserver {
my $port = pidfromfile($portfile); my $port = pidfromfile($portfile);
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server is now running PID $pid2\n"; logmsg "RUN: $srvrname server is now running PID $pid2\n";
} }
@ -2456,7 +2455,7 @@ sub runsocksserver {
# start the dict server # start the dict server
# #
sub rundictserver { sub rundictserver {
my ($verbose, $alt) = @_; my ($verb, $alt) = @_;
my $proto = "dict"; my $proto = "dict";
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $ipvnum = 4; my $ipvnum = 4;
@ -2514,7 +2513,7 @@ sub rundictserver {
} }
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $dictpid port $port\n"; logmsg "RUN: $srvrname server PID $dictpid port $port\n";
} }
last; last;
@ -2528,7 +2527,7 @@ sub rundictserver {
# start the SMB server # start the SMB server
# #
sub runsmbserver { sub runsmbserver {
my ($verbose, $alt) = @_; my ($verb, $alt) = @_;
my $proto = "smb"; my $proto = "smb";
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $ipvnum = 4; my $ipvnum = 4;
@ -2586,7 +2585,7 @@ sub runsmbserver {
} }
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $smbpid port $port\n"; logmsg "RUN: $srvrname server PID $smbpid port $port\n";
} }
last; last;
@ -2600,7 +2599,7 @@ sub runsmbserver {
# start the telnet server # start the telnet server
# #
sub runnegtelnetserver { sub runnegtelnetserver {
my ($verbose, $alt) = @_; my ($verb, $alt) = @_;
my $proto = "telnet"; my $proto = "telnet";
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $ipvnum = 4; my $ipvnum = 4;
@ -2657,7 +2656,7 @@ sub runnegtelnetserver {
} }
$doesntrun{$pidfile} = 0; $doesntrun{$pidfile} = 0;
if($verbose) { if($verb) {
logmsg "RUN: $srvrname server PID $ntelpid port $port\n"; logmsg "RUN: $srvrname server PID $ntelpid port $port\n";
} }
last; last;
@ -2673,7 +2672,7 @@ sub runnegtelnetserver {
# be used to verify that a server present in %run hash is still functional # be used to verify that a server present in %run hash is still functional
# #
sub responsive_http_server { sub responsive_http_server {
my ($proto, $verbose, $alt, $port_or_path) = @_; my ($proto, $verb, $alt, $port_or_path) = @_;
my $ip = $HOSTIP; my $ip = $HOSTIP;
my $ipvnum = 4; my $ipvnum = 4;
my $idnum = 1; my $idnum = 1;
@ -2699,7 +2698,7 @@ sub responsive_http_server {
# used to verify that a server present in %run hash is still functional # used to verify that a server present in %run hash is still functional
# #
sub responsive_pingpong_server { sub responsive_pingpong_server {
my ($proto, $id, $verbose, $ipv6) = @_; my ($proto, $id, $verb, $ipv6) = @_;
my $port; my $port;
my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 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 # used to verify that a server present in %run hash is still functional
# #
sub responsive_rtsp_server { sub responsive_rtsp_server {
my ($verbose, $ipv6) = @_; my ($verb, $ipv6) = @_;
my $proto = 'rtsp'; my $proto = 'rtsp';
my $port = protoport($proto); my $port = protoport($proto);
my $ip = $HOSTIP; my $ip = $HOSTIP;
@ -2744,7 +2743,7 @@ sub responsive_rtsp_server {
# used to verify that a server present in %run hash is still functional # used to verify that a server present in %run hash is still functional
# #
sub responsive_tftp_server { sub responsive_tftp_server {
my ($id, $verbose, $ipv6) = @_; my ($id, $verb, $ipv6) = @_;
my $proto = 'tftp'; my $proto = 'tftp';
my $port = protoport($proto); my $port = protoport($proto);
my $ip = $HOSTIP; my $ip = $HOSTIP;
@ -2767,7 +2766,7 @@ sub responsive_tftp_server {
# server present in %run hash is still functional # server present in %run hash is still functional
# #
sub responsive_httptls_server { sub responsive_httptls_server {
my ($verbose, $ipv6) = @_; my ($verb, $ipv6) = @_;
my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
my $proto = "httptls"; my $proto = "httptls";
my $port = protoport($proto); my $port = protoport($proto);
@ -2797,8 +2796,8 @@ sub clearlocks {
$handle = "handle64.exe"; $handle = "handle64.exe";
} }
my @handles = `$handle $dir -accepteula -nobanner`; my @handles = `$handle $dir -accepteula -nobanner`;
for $handle (@handles) { for my $tryhandle (@handles) {
if($handle =~ /^(\S+)\s+pid:\s+(\d+)\s+type:\s+(\w+)\s+([0-9A-F]+):\s+(.+)\r\r/) { 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"; logmsg "Found $3 lock of '$5' ($4) by $1 ($2)\n";
# Ignore stunnel since we cannot do anything about its locks # Ignore stunnel since we cannot do anything about its locks
if("$3" eq "File" && "$1" ne "tstunnel.exe") { if("$3" eq "File" && "$1" ne "tstunnel.exe") {
@ -2905,7 +2904,7 @@ sub checksystemfeatures {
close(DISABLED); close(DISABLED);
if($disabled[0]) { if($disabled[0]) {
map s/[\r\n]//g, @disabled; s/[\r\n]//g for @disabled;
$dis = join(", ", @disabled); $dis = join(", ", @disabled);
} }
@ -2915,8 +2914,8 @@ sub checksystemfeatures {
if($_ =~ /^curl ([^ ]*)/) { if($_ =~ /^curl ([^ ]*)/) {
$curl = $_; $curl = $_;
$VERSION = $1; $CURLVERSION = $1;
$curl =~ s/^(.*)(libcurl.*)/$1/g; $curl =~ s/^(.*)(libcurl.*)/$1/g || die "Failure determining curl binary version";
$libcurl = $2; $libcurl = $2;
if($curl =~ /linux|bsd|solaris/) { if($curl =~ /linux|bsd|solaris/) {
@ -3334,7 +3333,7 @@ sub subVariables {
$$thing =~ s/${prefix}CURL/$CURL/g; $$thing =~ s/${prefix}CURL/$CURL/g;
$$thing =~ s/${prefix}PWD/$pwd/g; $$thing =~ s/${prefix}PWD/$pwd/g;
$$thing =~ s/${prefix}POSIX_PWD/$posix_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; $$thing =~ s/${prefix}TESTNUMBER/$testnum/g;
my $file_pwd = $pwd; my $file_pwd = $pwd;
@ -3717,7 +3716,6 @@ sub singletest_shouldrun {
my @info_keywords = getpart("info", "keywords"); my @info_keywords = getpart("info", "keywords");
if(!$why) { if(!$why) {
my $match; my $match;
my $k;
# Clear the list of keywords from the last test # Clear the list of keywords from the last test
%keywords = (); %keywords = ();
@ -3726,7 +3724,7 @@ sub singletest_shouldrun {
$why = "missing the <keywords> section!"; $why = "missing the <keywords> section!";
} }
for $k (@info_keywords) { for my $k (@info_keywords) {
chomp $k; chomp $k;
if ($disabled_keywords{lc($k)}) { if ($disabled_keywords{lc($k)}) {
$why = "disabled by keyword"; $why = "disabled by keyword";
@ -3815,11 +3813,11 @@ sub singletest_preprocess {
@entiretest = prepro($testnum, @entiretest); @entiretest = prepro($testnum, @entiretest);
# save the new version # save the new version
open(D, ">$otest"); open(D, ">$otest") || die "Failure writing test file";
foreach my $bytes (@entiretest) { foreach my $bytes (@entiretest) {
print D pack('a*', $bytes) or die "Failed to print '$bytes': $!"; 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 # in case the process changed the file, reload it
loadtest("log/test${testnum}"); loadtest("log/test${testnum}");
@ -3830,31 +3828,29 @@ sub singletest_preprocess {
# Set up the test environment to run this test case # Set up the test environment to run this test case
sub singletest_setenv { sub singletest_setenv {
my @setenv = getpart("client", "setenv"); my @setenv = getpart("client", "setenv");
if(@setenv) { foreach my $s (@setenv) {
foreach my $s (@setenv) { chomp $s;
chomp $s; if($s =~ /([^=]*)=(.*)/) {
if($s =~ /([^=]*)=(.*)/) { my ($var, $content) = ($1, $2);
my ($var, $content) = ($1, $2); # remember current setting, to restore it once test runs
# remember current setting, to restore it once test runs $oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset';
$oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset'; # set new value
# set new value if(!$content) {
if(!$content) { delete $ENV{$var} if($ENV{$var});
delete $ENV{$var} if($ENV{$var}); }
} else {
else { if($var =~ /^LD_PRELOAD/) {
if($var =~ /^LD_PRELOAD/) { if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) {
if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) { # print "Skipping LD_PRELOAD due to lack of OS support\n";
# print "Skipping LD_PRELOAD due to lack of OS support\n"; next;
next; }
} if($feature{"debug"} || !$has_shared) {
if($feature{"debug"} || !$has_shared) { # print "Skipping LD_PRELOAD due to no release shared build\n";
# print "Skipping LD_PRELOAD due to no release shared build\n"; next;
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"); my %hash = getpartattr("client", "stdin");
if($hash{'nonewline'}) { if($hash{'nonewline'}) {
# cut off the final newline from the final line of the stdin data # cut off the final newline from the final line of the stdin data
chomp($stdintest[$#stdintest]); chomp($stdintest[-1]);
} }
writearray($stdinfile, \@stdintest); writearray($stdinfile, \@stdintest);
@ -4154,20 +4150,20 @@ sub singletest_run {
logmsg "$CMDLINE\n"; logmsg "$CMDLINE\n";
} }
open(CMDLOG, ">", "$LOGDIR/$CURLLOG"); open(CMDLOG, ">", "$LOGDIR/$CURLLOG") || die "Failure writing log file";
print CMDLOG "$CMDLINE\n"; print CMDLOG "$CMDLINE\n";
close(CMDLOG); close(CMDLOG) || die "Failure writing log file";
my $dumped_core; my $dumped_core;
my $cmdres; my $cmdres;
if($gdbthis) { if($gdbthis) {
my $gdbinit = "$TESTDIR/gdbinit$testnum"; 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 "set args $cmdargs\n";
print GDBCMD "show args\n"; print GDBCMD "show args\n";
print GDBCMD "source $gdbinit\n" if -e $gdbinit; print GDBCMD "source $gdbinit\n" if -e $gdbinit;
close(GDBCMD); close(GDBCMD) || die "Failure writing gdb file";
} }
# Flush output. # Flush output.
@ -4215,9 +4211,9 @@ sub singletest_clean {
logmsg "core dumped\n"; logmsg "core dumped\n";
if(0 && $gdb) { if(0 && $gdb) {
logmsg "running gdb for post-mortem analysis:\n"; 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"; print GDBCMD "bt\n";
close(GDBCMD); close(GDBCMD) || die "Failure writing gdb file";
runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch $DBGCURL core "); runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch $DBGCURL core ");
# unlink("$LOGDIR/gdbcmd2"); # unlink("$LOGDIR/gdbcmd2");
} }
@ -4354,20 +4350,20 @@ sub singletest_check {
my $filemode=$hash{'mode'}; my $filemode=$hash{'mode'};
if($filemode && ($filemode eq "text") && $has_textaware) { if($filemode && ($filemode eq "text") && $has_textaware) {
# text mode when running on windows: fix line endings # text mode when running on windows: fix line endings
map s/\r\n/\n/g, @validstdout; s/\r\n/\n/g for @validstdout;
map s/\n/\r\n/g, @validstdout; s/\n/\r\n/g for @validstdout;
} }
if($hash{'nonewline'}) { if($hash{'nonewline'}) {
# Yes, we must cut off the final newline from the final line # Yes, we must cut off the final newline from the final line
# of the protocol data # of the protocol data
chomp($validstdout[$#validstdout]); chomp($validstdout[-1]);
} }
if($hash{'crlf'} || if($hash{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"} ($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) { || $keywords{"HTTPS"}))) {
map subNewlines(0, \$_), @validstdout; subNewlines(0, \$_) for @validstdout;
} }
$res = compare($testnum, $testname, "stdout", \@actual, \@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 # text mode check in hyper-mode. Sometimes necessary if the stderr
# data *looks* like HTTP and thus has gotten CRLF newlines # data *looks* like HTTP and thus has gotten CRLF newlines
# mistakenly # mistakenly
map s/\r\n/\n/g, @validstderr; s/\r\n/\n/g for @validstderr;
} }
if($filemode && ($filemode eq "text") && $has_textaware) { if($filemode && ($filemode eq "text") && $has_textaware) {
# text mode when running on windows: fix line endings # text mode when running on windows: fix line endings
map s/\r\n/\n/g, @validstderr; s/\r\n/\n/g for @validstderr;
map s/\n/\r\n/g, @validstderr; s/\n/\r\n/g for @validstderr;
} }
if($hash{'nonewline'}) { if($hash{'nonewline'}) {
# Yes, we must cut off the final newline from the final line # Yes, we must cut off the final newline from the final line
# of the protocol data # of the protocol data
chomp($validstderr[$#validstderr]); chomp($validstderr[-1]);
} }
$res = compare($testnum, $testname, "stderr", \@actual, \@validstderr); $res = compare($testnum, $testname, "stderr", \@actual, \@validstderr);
@ -4450,7 +4446,7 @@ sub singletest_check {
if($hash{'nonewline'}) { if($hash{'nonewline'}) {
# Yes, we must cut off the final newline from the final line # Yes, we must cut off the final newline from the final line
# of the protocol data # of the protocol data
chomp($protocol[$#protocol]); chomp($protocol[-1]);
} }
for(@strip) { for(@strip) {
@ -4460,9 +4456,7 @@ sub singletest_check {
@protocol= striparray( $_, \@protocol); @protocol= striparray( $_, \@protocol);
} }
my $strip; for my $strip (@strippart) {
for $strip (@strippart) {
chomp $strip; chomp $strip;
for(@out) { for(@out) {
eval $strip; eval $strip;
@ -4470,7 +4464,7 @@ sub singletest_check {
} }
if($hash{'crlf'}) { if($hash{'crlf'}) {
map subNewlines(1, \$_), @protocol; subNewlines(1, \$_) for @protocol;
} }
if((!$out[0] || ($out[0] eq "")) && $protocol[0]) { if((!$out[0] || ($out[0] eq "")) && $protocol[0]) {
@ -4503,18 +4497,18 @@ sub singletest_check {
my $filemode=$replycheckpartattr{'mode'}; my $filemode=$replycheckpartattr{'mode'};
if($filemode && ($filemode eq "text") && $has_textaware) { if($filemode && ($filemode eq "text") && $has_textaware) {
# text mode when running on windows: fix line endings # text mode when running on windows: fix line endings
map s/\r\n/\n/g, @replycheckpart; s/\r\n/\n/g for @replycheckpart;
map s/\n/\r\n/g, @replycheckpart; s/\n/\r\n/g for @replycheckpart;
} }
if($replycheckpartattr{'nonewline'}) { if($replycheckpartattr{'nonewline'}) {
# Yes, we must cut off the final newline from the final line # Yes, we must cut off the final newline from the final line
# of the datacheck # of the datacheck
chomp($replycheckpart[$#replycheckpart]); chomp($replycheckpart[-1]);
} }
if($replycheckpartattr{'crlf'} || if($replycheckpartattr{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"} ($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) { || $keywords{"HTTPS"}))) {
map subNewlines(0, \$_), @replycheckpart; subNewlines(0, \$_) for @replycheckpart;
} }
push(@reply, @replycheckpart); push(@reply, @replycheckpart);
} }
@ -4526,20 +4520,20 @@ sub singletest_check {
if(@reply) { if(@reply) {
if($replyattr{'nonewline'}) { if($replyattr{'nonewline'}) {
# cut off the final newline from the final line of the data # cut off the final newline from the final line of the data
chomp($reply[$#reply]); chomp($reply[-1]);
} }
} }
# get the mode attribute # get the mode attribute
my $filemode=$replyattr{'mode'}; my $filemode=$replyattr{'mode'};
if($filemode && ($filemode eq "text") && $has_textaware) { if($filemode && ($filemode eq "text") && $has_textaware) {
# text mode when running on windows: fix line endings # text mode when running on windows: fix line endings
map s/\r\n/\n/g, @reply; s/\r\n/\n/g for @reply;
map s/\n/\r\n/g, @reply; s/\n/\r\n/g for @reply;
} }
if($replyattr{'crlf'} || if($replyattr{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"} ($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) { || $keywords{"HTTPS"}))) {
map subNewlines(0, \$_), @reply; subNewlines(0, \$_) for @reply;
} }
} }
@ -4562,13 +4556,12 @@ sub singletest_check {
my %hash = getpartattr("verify", "upload"); my %hash = getpartattr("verify", "upload");
if($hash{'nonewline'}) { if($hash{'nonewline'}) {
# cut off the final newline from the final line of the upload data # cut off the final newline from the final line of the upload data
chomp($upload[$#upload]); chomp($upload[-1]);
} }
# verify uploaded data # verify uploaded data
my @out = loadarray("$LOGDIR/upload.$testnum"); my @out = loadarray("$LOGDIR/upload.$testnum");
my $strip; for my $strip (@strippart) {
for $strip (@strippart) {
chomp $strip; chomp $strip;
for(@out) { for(@out) {
eval $strip; eval $strip;
@ -4595,7 +4588,7 @@ sub singletest_check {
if($hash{'nonewline'}) { if($hash{'nonewline'}) {
# Yes, we must cut off the final newline from the final line # Yes, we must cut off the final newline from the final line
# of the protocol data # of the protocol data
chomp($proxyprot[$#proxyprot]); chomp($proxyprot[-1]);
} }
my @out = loadarray($PROXYIN); my @out = loadarray($PROXYIN);
@ -4606,8 +4599,7 @@ sub singletest_check {
@proxyprot= striparray( $_, \@proxyprot); @proxyprot= striparray( $_, \@proxyprot);
} }
my $strip; for my $strip (@strippart) {
for $strip (@strippart) {
chomp $strip; chomp $strip;
for(@out) { for(@out) {
eval $strip; eval $strip;
@ -4616,7 +4608,7 @@ sub singletest_check {
if($hash{'crlf'} || if($hash{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) {
map subNewlines(0, \$_), @proxyprot; subNewlines(0, \$_) for @proxyprot;
} }
$res = compare($testnum, $testname, "proxy", \@out, \@proxyprot); $res = compare($testnum, $testname, "proxy", \@out, \@proxyprot);
@ -4650,22 +4642,21 @@ sub singletest_check {
my @generated=loadarray($filename); my @generated=loadarray($filename);
# what parts to cut off from the file # what parts to cut off from the file
my @stripfile = getpart("verify", "stripfile".$partsuffix); my @stripfilepar = getpart("verify", "stripfile".$partsuffix);
my $filemode=$hash{'mode'}; my $filemode=$hash{'mode'};
if($filemode && ($filemode eq "text") && $has_textaware) { if($filemode && ($filemode eq "text") && $has_textaware) {
# text mode when running on windows: fix line endings # text mode when running on windows: fix line endings
map s/\r\n/\n/g, @outfile; s/\r\n/\n/g for @outfile;
map s/\n/\r\n/g, @outfile; s/\n/\r\n/g for @outfile;
} }
if($hash{'crlf'} || if($hash{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"} ($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) { || $keywords{"HTTPS"}))) {
map subNewlines(0, \$_), @outfile; subNewlines(0, \$_) for @outfile;
} }
my $strip; for my $strip (@stripfilepar) {
for $strip (@stripfile) {
chomp $strip; chomp $strip;
my @newgen; my @newgen;
for(@generated) { for(@generated) {
@ -4761,7 +4752,7 @@ sub singletest_check {
if($valgrind) { if($valgrind) {
if(use_valgrind() && !$disablevalgrind) { if(use_valgrind() && !$disablevalgrind) {
unless(opendir(DIR, "$LOGDIR")) { if(!opendir(DIR, "$LOGDIR")) {
logmsg "ERROR: unable to read $LOGDIR\n"; logmsg "ERROR: unable to read $LOGDIR\n";
# timestamp test result verification end # timestamp test result verification end
$timevrfyend{$testnum} = Time::HiRes::time(); $timevrfyend{$testnum} = Time::HiRes::time();
@ -4827,7 +4818,7 @@ sub singletest_success {
my $sofar= time()-$start; my $sofar= time()-$start;
my $esttotal = $sofar/$count * $total; my $esttotal = $sofar/$count * $total;
my $estleft = $esttotal - $sofar; my $estleft = $esttotal - $sofar;
my $left=sprintf("remaining: %02d:%02d", my $timeleft=sprintf("remaining: %02d:%02d",
$estleft/60, $estleft/60,
$estleft%60); $estleft%60);
my $took = $timevrfyend{$testnum} - $timeprepini{$testnum}; my $took = $timevrfyend{$testnum} - $timeprepini{$testnum};
@ -4835,7 +4826,7 @@ sub singletest_success {
$sofar/60, $sofar%60); $sofar/60, $sofar%60);
if(!$automakestyle) { if(!$automakestyle) {
logmsg sprintf("OK (%-3d out of %-3d, %s, took %.3fs, %s)\n", logmsg sprintf("OK (%-3d out of %-3d, %s, took %.3fs, %s)\n",
$count, $total, $left, $took, $duration); $count, $total, $timeleft, $took, $duration);
} }
else { else {
my $testname= (getpart("client", "name"))[0]; my $testname= (getpart("client", "name"))[0];
@ -4958,18 +4949,18 @@ sub singletest {
# Stop all running test servers # Stop all running test servers
# #
sub stopservers { sub stopservers {
my $verbose = $_[0]; my $verb = $_[0];
# #
# kill sockfilter processes for all pingpong servers # kill sockfilter processes for all pingpong servers
# #
killallsockfilters($verbose); killallsockfilters($verb);
# #
# kill all server pids from %run hash clearing them # kill all server pids from %run hash clearing them
# #
my $pidlist; my $pidlist;
foreach my $server (keys %run) { foreach my $server (keys %run) {
if($run{$server}) { if($run{$server}) {
if($verbose) { if($verb) {
my $prev = 0; my $prev = 0;
my $pids = $run{$server}; my $pids = $run{$server};
foreach my $pid (split(' ', $pids)) { foreach my $pid (split(' ', $pids)) {
@ -4985,7 +4976,7 @@ sub stopservers {
} }
$runcert{$server} = 0 if($runcert{$server}); $runcert{$server} = 0 if($runcert{$server});
} }
killpid($verbose, $pidlist); killpid($verb, $pidlist);
# #
# cleanup all server pid files # cleanup all server pid files
# #
@ -5002,7 +4993,7 @@ sub stopservers {
logmsg "Warning: "; logmsg "Warning: ";
} }
logmsg "$server server unexpectedly alive\n"; logmsg "$server server unexpectedly alive\n";
killpid($verbose, $pid); killpid($verb, $pid);
} }
unlink($pidfile) if(-f $pidfile); unlink($pidfile) if(-f $pidfile);
} }
@ -5795,7 +5786,7 @@ while(@ARGV) {
die "Unsupported type: $type\n" if($type !~ /^keyword|test|tool$/); die "Unsupported type: $type\n" if($type !~ /^keyword|test|tool$/);
foreach my $pattern (split(/,/, $patterns)) { foreach my $pattern (split(/,/, $patterns)) {
if($type =~ /^test$/) { if($type eq "test") {
# Strip leading zeros in the test number # Strip leading zeros in the test number
$pattern = int($pattern); $pattern = int($pattern);
} }
@ -5929,7 +5920,7 @@ while(@ARGV) {
} }
elsif(($ARGV[0] eq "-h") || ($ARGV[0] eq "--help")) { elsif(($ARGV[0] eq "-h") || ($ARGV[0] eq "--help")) {
# show help text # show help text
print <<EOHELP print <<"EOHELP"
Usage: runtests.pl [options] [test selection(s)] Usage: runtests.pl [options] [test selection(s)]
-a continue even if a test fails -a continue even if a test fails
-ac path use this curl only to talk to APIs (currently only CI test APIs) -ac path use this curl only to talk to APIs (currently only CI test APIs)
@ -6183,11 +6174,11 @@ if ( $TESTCASES eq "all") {
} }
else { else {
my $verified=""; my $verified="";
map { for(split(" ", $TESTCASES)) {
if (-e "$TESTDIR/test$_") { if (-e "$TESTDIR/test$_") {
$verified.="$_ "; $verified.="$_ ";
} }
} split(" ", $TESTCASES); }
if($verified eq "") { if($verified eq "") {
print "No existing test cases were specified\n"; print "No existing test cases were specified\n";
exit; exit;
@ -6232,7 +6223,7 @@ sub displaylogcontent {
$string =~ s/[\r\f\032]/\n/g; $string =~ s/[\r\f\032]/\n/g;
$string .= "\n" unless ($string =~ /\n$/); $string .= "\n" unless ($string =~ /\n$/);
$string =~ tr/\n//; $string =~ tr/\n//;
for my $line (split("\n", $string)) { for my $line (split(m/\n/, $string)) {
$line =~ s/\s*\!$//; $line =~ s/\s*\!$//;
if ($truncate) { if ($truncate) {
push @tail, " $line\n"; push @tail, " $line\n";
@ -6243,6 +6234,7 @@ sub displaylogcontent {
$truncate = $linecount > 1000; $truncate = $linecount > 1000;
} }
} }
close(SINGLE);
if(@tail) { if(@tail) {
my $tailshow = 200; my $tailshow = 200;
my $tailskip = 0; my $tailskip = 0;
@ -6255,7 +6247,6 @@ sub displaylogcontent {
logmsg "$tail[$_]"; logmsg "$tail[$_]";
} }
} }
close(SINGLE);
} }
} }
@ -6304,7 +6295,7 @@ sub displaylogs {
if(($log =~ /^trace\d+/) && ($log !~ /^trace$testnum/)) { if(($log =~ /^trace\d+/) && ($log !~ /^trace$testnum/)) {
next; # skip traceNnn of other tests 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 next; # skip valgrindNnn of other tests
} }
if(($log =~ /^test$testnum$/)) { if(($log =~ /^test$testnum$/)) {
@ -6326,7 +6317,6 @@ citest_starttestrun();
my $failed; my $failed;
my $failedign; my $failedign;
my $testnum;
my $ok=0; my $ok=0;
my $ign=0; my $ign=0;
my $total=0; my $total=0;
@ -6336,7 +6326,7 @@ my $count=0;
$start = time(); $start = time();
foreach $testnum (@at) { foreach my $testnum (@at) {
$lasttest = $testnum if($testnum > $lasttest); $lasttest = $testnum if($testnum > $lasttest);
$count++; $count++;

7
tests/serverhelp.pm
View File

@ -26,14 +26,11 @@ package serverhelp;
use strict; use strict;
use warnings; use warnings;
use Exporter;
#*************************************************************************** #***************************************************************************
# Global symbols allowed without explicit package name # Global symbols allowed without explicit package name
# #
use vars qw( use vars qw(
@ISA
@EXPORT_OK @EXPORT_OK
); );
@ -41,7 +38,7 @@ use vars qw(
#*************************************************************************** #***************************************************************************
# Inherit Exporter's capabilities # Inherit Exporter's capabilities
# #
@ISA = qw(Exporter); use base qw(Exporter);
#*************************************************************************** #***************************************************************************
@ -118,7 +115,7 @@ sub servername_str {
$idnum = 1 if(not $idnum); $idnum = 1 if(not $idnum);
die "unsupported ID number: '$idnum'" unless($idnum && die "unsupported ID number: '$idnum'" unless($idnum &&
($idnum =~ /^(\d+)$/)); ($idnum =~ /^(\d+)$/));
$idnum = '' unless($idnum > 1); $idnum = '' if($idnum <= 1);
return "${proto}${idnum}${ipver}"; return "${proto}${idnum}${ipver}";
} }

9
tests/sshhelp.pm
View File

@ -26,7 +26,6 @@ package sshhelp;
use strict; use strict;
use warnings; use warnings;
use Exporter;
use File::Spec; use File::Spec;
@ -34,7 +33,6 @@ use File::Spec;
# Global symbols allowed without explicit package name # Global symbols allowed without explicit package name
# #
use vars qw( use vars qw(
@ISA
@EXPORT_OK @EXPORT_OK
$sshdexe $sshdexe
$sshexe $sshexe
@ -64,7 +62,7 @@ use vars qw(
#*************************************************************************** #***************************************************************************
# Inherit Exporter's capabilities # Inherit Exporter's capabilities
# #
@ISA = qw(Exporter); use base qw(Exporter);
#*************************************************************************** #***************************************************************************
@ -214,7 +212,7 @@ sub dump_array {
} }
elsif(open(TEXTFH, ">$filename")) { elsif(open(TEXTFH, ">$filename")) {
foreach my $line (@arr) { foreach my $line (@arr) {
$line .= "\n" unless($line =~ /\n$/); $line .= "\n" if($line !~ /\n$/);
print TEXTFH $line; print TEXTFH $line;
} }
if(!close(TEXTFH)) { if(!close(TEXTFH)) {
@ -319,6 +317,7 @@ sub find_file {
return $file; return $file;
} }
} }
return "";
} }
@ -337,6 +336,7 @@ sub find_exe_file {
return $file if(($xext) && (lc($file) =~ /\Q$xext\E$/)); return $file if(($xext) && (lc($file) =~ /\Q$xext\E$/));
} }
} }
return "";
} }
@ -420,6 +420,7 @@ sub find_httptlssrv {
} }
return $p if($found); return $p if($found);
} }
return "";
} }

3
tests/valgrind.pm
View File

@ -22,6 +22,9 @@
# #
########################################################################### ###########################################################################
use strict;
use warnings;
use File::Basename; use File::Basename;
sub valgrindparse { sub valgrindparse {