mirror/curl
2
0
Fork 0
mirror of https://github.com/curl/curl.git synced 2025-03-13 15:37:04 +08:00
Code Issues Packages Projects Releases Wiki Activity

runtests: refactor into more packages

Browse Source 
testutil.pm now contains a few miscellaneous functions that are used in
several places but have no better place to live.  subvariables moves to
servers.pm since most variables that it substitutes relate to servers,
so this is the most appropriate place. Rename a few functions for better
naming consistency.

Ref: #10818
Closes #10995
This commit is contained in:
Dan Fandrich 2023-04-14 17:22:05 -07:00
parent ba51b39732
commit 707f74c04a
6 changed files with 334 additions and 305 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
tests/Makefile.am
View File

@ -33,7 +33,8 @@ EXTRA_DIST = appveyor.pm azure.pm badsymbols.pl check-deprecated.pl CMakeLists.t
memanalyze.pl negtelnetserver.py nroff-scan.pl option-check.pl options-scan.pl \
pathhelp.pm README.md rtspserver.pl runner.pm runtests.1 runtests.pl secureserver.pl \
serverhelp.pm servers.pm smbserver.py sshhelp.pm sshserver.pl stunnel.pem symbol-scan.pl \
testcurl.1 testcurl.pl tftpserver.pl util.py valgrind.pm valgrind.supp version-scan.pl
testcurl.1 testcurl.pl testutil.pm tftpserver.pl util.py valgrind.pm \
valgrind.supp version-scan.pl
DISTCLEANFILES = configurehelp.pm

41
tests/globalconfig.pm
View File

@ -34,41 +34,44 @@ BEGIN {
use base qw(Exporter);
our @EXPORT = qw(
$anyway
$automakestyle
$CURL
$CURLVERSION
$FTPDCMD
$has_shared
$LIBDIR
$listonly
$LOGDIR
$memanalyze
$memdump
$perl
$PIDDIR
$SERVERIN
$SERVER2IN
$PROXYIN
$TESTDIR
$memdump
$proxy_address
$listonly
$PROXYIN
$pwd
$run_event_based
$SERVER2IN
$SERVERIN
$srcdir
$TESTDIR
$torture
$valgrind
$VCURL
$verbose
$memanalyze
@protocols
$anyway
%feature
$has_shared
%timesrvrini
%timesrvrend
%timetoolini
%timetoolend
%timesrvrlog
%timevrfyend
$valgrind
%keywords
$automakestyle
@protocols
%timesrvrend
%timesrvrini
%timesrvrlog
%timetoolend
%timetoolini
%timevrfyend
);
}
use pathhelp qw(exe_ext);
use Cwd qw(getcwd);
#######################################################################
@ -83,8 +86,10 @@ our $listonly; # only list the tests
our $run_event_based; # run curl with --test-event to test the event API
our $automakestyle; # use automake-like test status output format
our $anyway; # continue anyway, even if a test fail
our $CURLVERSION=""; # curl's reported version number
# paths
our $pwd = getcwd(); # current working directory
our $srcdir = $ENV{'srcdir'} || '.'; # root of the test source code
our $perl="perl -I$srcdir"; # invoke perl like this
our $LOGDIR="log"; # root of the log directory

74
tests/runner.pm
View File

@ -33,6 +33,7 @@ BEGIN {
use base qw(Exporter);
our @EXPORT = qw(
prepro
restore_test_env
runner_test_preprocess
runner_test_run
@ -47,6 +48,11 @@ BEGIN {
$valgrind_tool
$gdb
);
# these are for debugging only
our @EXPORT_OK = qw(
singletest_preprocess
);
}
use pathhelp qw(
@ -59,6 +65,7 @@ use processhelp qw(
use servers;
use getpart;
use globalconfig;
use testutil;
#######################################################################
@ -97,21 +104,6 @@ sub displaylogs{
return main::displaylogs(@_);
}
#######################################################################
# Call main's prepro
# TODO: figure out where this should live; since it needs to know
# things in main:: only, maybe the test file should be preprocessed there
sub prepro {
return main::prepro(@_);
}
#######################################################################
# Call main's runclient
# TODO: move this into a helper package
sub runclient {
return main::runclient(@_);
}
#######################################################################
# Check for a command in the PATH of the machine running curl.
#
@ -148,6 +140,58 @@ sub normalize_cmdres {
return ($cmdres, $dumped_core);
}
# 'prepro' processes the input array and replaces %-variables in the array
# etc. Returns the processed version of the array
sub prepro {
my $testnum = shift;
my (@entiretest) = @_;
my $show = 1;
my @out;
my $data_crlf;
for my $s (@entiretest) {
my $f = $s;
if($s =~ /^ *%if (.*)/) {
my $cond = $1;
my $rev = 0;
if($cond =~ /^!(.*)/) {
$cond = $1;
$rev = 1;
}
$rev ^= $feature{$cond} ? 1 : 0;
$show = $rev;
next;
}
elsif($s =~ /^ *%else/) {
$show ^= 1;
next;
}
elsif($s =~ /^ *%endif/) {
$show = 1;
next;
}
if($show) {
# The processor does CRLF replacements in the <data*> sections if
# necessary since those parts might be read by separate servers.
if($s =~ /^ *<data(.*)\>/) {
if($1 =~ /crlf="yes"/ ||
($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) {
$data_crlf = 1;
}
}
elsif(($s =~ /^ *<\/data/) && $data_crlf) {
$data_crlf = 0;
}
subvariables(\$s, $testnum, "%");
subbase64(\$s);
subnewlines(0, \$s) if($data_crlf);
push @out, $s;
}
}
return @out;
}
#######################################################################
# Memory allocation test and failure torture testing.
#

264
tests/runtests.pl
View File

@ -78,9 +78,7 @@ BEGIN {
}
}
use Cwd;
use Digest::MD5 qw(md5);
use MIME::Base64;
use List::Util 'sum';
use pathhelp qw(
@ -98,14 +96,10 @@ use servers;
use valgrind; # valgrind report parser
use globalconfig;
use runner;
my $CLIENTIP="127.0.0.1"; # address which curl uses for incoming connections
my $CLIENT6IP="[::1]"; # address which curl uses for incoming connections
use testutil;
my %custom_skip_reasons;
my $CURLVERSION=""; # curl's reported version number
my $ACURL=$VCURL; # what curl binary to use to talk to APIs (relevant for CI)
# ACURL is handy to set to the system one for reliability
my $CURLCONFIG="../curl-config"; # curl-config from current build
@ -124,9 +118,6 @@ my $TESTCASES="all";
my $libtool;
my $repeat = 0;
my $pwd = getcwd(); # current working directory
my $posix_pwd = $pwd;
my $start; # time at which testing started
my $uname_release = `uname -r`;
@ -136,9 +127,6 @@ my $http_ipv6; # set if HTTP server has IPv6 support
my $http_unix; # set if HTTP server has Unix sockets support
my $ftp_ipv6; # set if FTP server has IPv6 support
# this version is decided by the particular nghttp2 library that is being used
my $h2cver = "h2c";
my $resolver; # name of the resolver backend (for human presentation)
my $has_textaware; # set if running on a system that has a text mode concept
@ -267,35 +255,6 @@ sub get_disttests {
close($dh);
}
#######################################################################
# Run the application under test and return its return code
#
sub runclient {
my ($cmd)=@_;
my $ret = system($cmd);
print "CMD ($ret): $cmd\n" if($verbose && !$torture);
return $ret;
# This is one way to test curl on a remote machine
# my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
# sleep 2; # time to allow the NFS server to be updated
# return $out;
}
#######################################################################
# Run the application under test and return its stdout
#
sub runclientoutput {
my ($cmd)=@_;
return `$cmd 2>/dev/null`;
# This is one way to test curl on a remote machine
# my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
# sleep 2; # time to allow the NFS server to be updated
# return @out;
}
#######################################################################
# Remove all files in the specified directory
@ -774,163 +733,6 @@ sub displayserverfeatures {
logmsg "***************************************** \n";
}
#######################################################################
# substitute the variable stuff into either a joined up file or
# a command, in either case passed by reference
#
sub subVariables {
my ($thing, $testnum, $prefix) = @_;
my $port;
if(!$prefix) {
$prefix = "%";
}
# test server ports
# Substitutes variables like %HTTPPORT and %SMTP6PORT with the server ports
foreach my $proto ('DICT',
'FTP', 'FTP6', 'FTPS',
'GOPHER', 'GOPHER6', 'GOPHERS',
'HTTP', 'HTTP6', 'HTTPS',
'HTTPSPROXY', 'HTTPTLS', 'HTTPTLS6',
'HTTP2', 'HTTP2TLS',
'HTTP3',
'IMAP', 'IMAP6', 'IMAPS',
'MQTT',
'NOLISTEN',
'POP3', 'POP36', 'POP3S',
'RTSP', 'RTSP6',
'SMB', 'SMBS',
'SMTP', 'SMTP6', 'SMTPS',
'SOCKS',
'SSH',
'TELNET',
'TFTP', 'TFTP6') {
$port = protoport(lc $proto);
$$thing =~ s/${prefix}(?:$proto)PORT/$port/g;
}
# Special case: for PROXYPORT substitution, use httpproxy.
$port = protoport('httpproxy');
$$thing =~ s/${prefix}PROXYPORT/$port/g;
# server Unix domain socket paths
$$thing =~ s/${prefix}HTTPUNIXPATH/$HTTPUNIXPATH/g;
$$thing =~ s/${prefix}SOCKSUNIXPATH/$SOCKSUNIXPATH/g;
# client IP addresses
$$thing =~ s/${prefix}CLIENT6IP/$CLIENT6IP/g;
$$thing =~ s/${prefix}CLIENTIP/$CLIENTIP/g;
# server IP addresses
$$thing =~ s/${prefix}HOST6IP/$HOST6IP/g;
$$thing =~ s/${prefix}HOSTIP/$HOSTIP/g;
# misc
$$thing =~ s/${prefix}CURL/$CURL/g;
$$thing =~ s/${prefix}LOGDIR/$LOGDIR/g;
$$thing =~ s/${prefix}PWD/$pwd/g;
$$thing =~ s/${prefix}POSIX_PWD/$posix_pwd/g;
$$thing =~ s/${prefix}VERSION/$CURLVERSION/g;
$$thing =~ s/${prefix}TESTNUMBER/$testnum/g;
my $file_pwd = $pwd;
if($file_pwd !~ /^\//) {
$file_pwd = "/$file_pwd";
}
my $ssh_pwd = $posix_pwd;
# this only works after the SSH server has been started
# TODO: call sshversioninfo early and store $sshdid so this substitution
# always works
if ($sshdid && $sshdid =~ /OpenSSH-Windows/) {
$ssh_pwd = $file_pwd;
}
$$thing =~ s/${prefix}FILE_PWD/$file_pwd/g;
$$thing =~ s/${prefix}SSH_PWD/$ssh_pwd/g;
$$thing =~ s/${prefix}SRCDIR/$srcdir/g;
$$thing =~ s/${prefix}USER/$USER/g;
$$thing =~ s/${prefix}SSHSRVMD5/$SSHSRVMD5/g;
$$thing =~ s/${prefix}SSHSRVSHA256/$SSHSRVSHA256/g;
# The purpose of FTPTIME2 and FTPTIME3 is to provide times that can be
# used for time-out tests and that would work on most hosts as these
# adjust for the startup/check time for this particular host. We needed to
# do this to make the test suite run better on very slow hosts.
my $ftp2 = $ftpchecktime * 2;
my $ftp3 = $ftpchecktime * 3;
$$thing =~ s/${prefix}FTPTIME2/$ftp2/g;
$$thing =~ s/${prefix}FTPTIME3/$ftp3/g;
# HTTP2
$$thing =~ s/${prefix}H2CVER/$h2cver/g;
}
sub subBase64 {
my ($thing) = @_;
# cut out the base64 piece
if($$thing =~ s/%b64\[(.*)\]b64%/%%B64%%/i) {
my $d = $1;
# encode %NN characters
$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
my $enc = encode_base64($d, "");
# put the result into there
$$thing =~ s/%%B64%%/$enc/;
}
# hex decode
if($$thing =~ s/%hex\[(.*)\]hex%/%%HEX%%/i) {
# decode %NN characters
my $d = $1;
$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
$$thing =~ s/%%HEX%%/$d/;
}
if($$thing =~ s/%repeat\[(\d+) x (.*)\]%/%%REPEAT%%/i) {
# decode %NN characters
my ($d, $n) = ($2, $1);
$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
my $all = $d x $n;
$$thing =~ s/%%REPEAT%%/$all/;
}
}
my $prevupdate;
sub subNewlines {
my ($force, $thing) = @_;
if($force) {
# enforce CRLF newline
$$thing =~ s/\x0d*\x0a/\x0d\x0a/;
return;
}
# When curl is built with Hyper, it gets all response headers delivered as
# name/value pairs and curl "invents" the newlines when it saves the
# headers. Therefore, curl will always save headers with CRLF newlines
# when built to use Hyper. By making sure we deliver all tests using CRLF
# as well, all test comparisons will survive without knowing about this
# little quirk.
if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
(($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
# skip curl error messages
($$thing !~ /^curl: \(\d+\) /))) {
# enforce CRLF newline
$$thing =~ s/\x0d*\x0a/\x0d\x0a/;
$prevupdate = 1;
}
else {
if(($$thing =~ /^\n\z/) && $prevupdate) {
# if there's a blank link after a line we update, we hope it is
# the empty line following headers
$$thing =~ s/\x0a/\x0d\x0a/;
}
$prevupdate = 0;
}
}
#######################################################################
# Provide time stamps for single test skipped events
#
@ -981,58 +783,6 @@ sub timestampskippedevents {
}
}
#
# 'prepro' processes the input array and replaces %-variables in the array
# etc. Returns the processed version of the array
sub prepro {
my $testnum = shift;
my (@entiretest) = @_;
my $show = 1;
my @out;
my $data_crlf;
for my $s (@entiretest) {
my $f = $s;
if($s =~ /^ *%if (.*)/) {
my $cond = $1;
my $rev = 0;
if($cond =~ /^!(.*)/) {
$cond = $1;
$rev = 1;
}
$rev ^= $feature{$cond} ? 1 : 0;
$show = $rev;
next;
}
elsif($s =~ /^ *%else/) {
$show ^= 1;
next;
}
elsif($s =~ /^ *%endif/) {
$show = 1;
next;
}
if($show) {
# The processor does CRLF replacements in the <data*> sections if
# necessary since those parts might be read by separate servers.
if($s =~ /^ *<data(.*)\>/) {
if($1 =~ /crlf="yes"/ ||
($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) {
$data_crlf = 1;
}
}
elsif(($s =~ /^ *<\/data/) && $data_crlf) {
$data_crlf = 0;
}
subVariables(\$s, $testnum, "%");
subBase64(\$s);
subNewlines(0, \$s) if($data_crlf);
push @out, $s;
}
}
return @out;
}
# Setup CI Test Run
sub citest_starttestrun {
@ -1322,7 +1072,7 @@ sub singletest_check {
if($hash{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) {
subNewlines(0, \$_) for @validstdout;
subnewlines(0, \$_) for @validstdout;
}
$res = compare($testnum, $testname, "stdout", \@actual, \@validstdout);
@ -1423,7 +1173,7 @@ sub singletest_check {
}
if($hash{'crlf'}) {
subNewlines(1, \$_) for @protocol;
subnewlines(1, \$_) for @protocol;
}
if((!$out[0] || ($out[0] eq "")) && $protocol[0]) {
@ -1469,7 +1219,7 @@ sub singletest_check {
if($replycheckpartattr{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) {
subNewlines(0, \$_) for @replycheckpart;
subnewlines(0, \$_) for @replycheckpart;
}
push(@reply, @replycheckpart);
}
@ -1494,7 +1244,7 @@ sub singletest_check {
if($replyattr{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) {
subNewlines(0, \$_) for @reply;
subnewlines(0, \$_) for @reply;
}
}
@ -1569,7 +1319,7 @@ sub singletest_check {
if($hash{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) {
subNewlines(0, \$_) for @proxyprot;
subnewlines(0, \$_) for @proxyprot;
}
$res = compare($testnum, $testname, "proxy", \@out, \@proxyprot);
@ -1614,7 +1364,7 @@ sub singletest_check {
if($hash{'crlf'} ||
($feature{"hyper"} && ($keywords{"HTTP"}
|| $keywords{"HTTPS"}))) {
subNewlines(0, \$_) for @outfile;
subnewlines(0, \$_) for @outfile;
}
for my $strip (@stripfilepar) {

114
tests/servers.pm
View File

@ -61,6 +61,7 @@ BEGIN {
serverfortest
stopserver
stopservers
subvariables
)
);
}
@ -103,6 +104,7 @@ use pathhelp qw(
use processhelp;
use globalconfig;
use testutil;
my %serverpidfile; # all server pid file names, identified by server id
@ -117,6 +119,10 @@ my $httptlssrv = find_httptlssrv();
my %run; # running server
my %runcert; # cert file currently in use by an ssl running server
my $serverstartretries=10; # number of times to attempt to start server
my $CLIENTIP="127.0.0.1"; # address which curl uses for incoming connections
my $CLIENT6IP="[::1]"; # address which curl uses for incoming connections
my $posix_pwd=$pwd; # current working directory
my $h2cver = "h2c"; # this version is decided by the nghttp2 lib being used
# Variables shared with runtests.pl
our $HOSTIP="127.0.0.1"; # address on which the test server listens
@ -141,20 +147,6 @@ sub logmsg {
return main::logmsg(@_);
}
#######################################################################
# Call main's runclient
# TODO: move this into a helper package
sub runclient {
return main::runclient(@_);
}
#######################################################################
# Call main's runclientoutput
# TODO: move this into a helper package
sub runclientoutput {
return main::runclientoutput(@_);
}
#######################################################################
# Check for a command in the PATH of the test server.
#
@ -2943,4 +2935,98 @@ sub stopservers {
}
#######################################################################
# substitute the variable stuff into either a joined up file or
# a command, in either case passed by reference
#
sub subvariables {
my ($thing, $testnum, $prefix) = @_;
my $port;
if(!$prefix) {
$prefix = "%";
}
# test server ports
# Substitutes variables like %HTTPPORT and %SMTP6PORT with the server ports
foreach my $proto ('DICT',
'FTP', 'FTP6', 'FTPS',
'GOPHER', 'GOPHER6', 'GOPHERS',
'HTTP', 'HTTP6', 'HTTPS',
'HTTPSPROXY', 'HTTPTLS', 'HTTPTLS6',
'HTTP2', 'HTTP2TLS',
'HTTP3',
'IMAP', 'IMAP6', 'IMAPS',
'MQTT',
'NOLISTEN',
'POP3', 'POP36', 'POP3S',
'RTSP', 'RTSP6',
'SMB', 'SMBS',
'SMTP', 'SMTP6', 'SMTPS',
'SOCKS',
'SSH',
'TELNET',
'TFTP', 'TFTP6') {
$port = protoport(lc $proto);
$$thing =~ s/${prefix}(?:$proto)PORT/$port/g;
}
# Special case: for PROXYPORT substitution, use httpproxy.
$port = protoport('httpproxy');
$$thing =~ s/${prefix}PROXYPORT/$port/g;
# server Unix domain socket paths
$$thing =~ s/${prefix}HTTPUNIXPATH/$HTTPUNIXPATH/g;
$$thing =~ s/${prefix}SOCKSUNIXPATH/$SOCKSUNIXPATH/g;
# client IP addresses
$$thing =~ s/${prefix}CLIENT6IP/$CLIENT6IP/g;
$$thing =~ s/${prefix}CLIENTIP/$CLIENTIP/g;
# server IP addresses
$$thing =~ s/${prefix}HOST6IP/$HOST6IP/g;
$$thing =~ s/${prefix}HOSTIP/$HOSTIP/g;
# misc
$$thing =~ s/${prefix}CURL/$CURL/g;
$$thing =~ s/${prefix}LOGDIR/$LOGDIR/g;
$$thing =~ s/${prefix}PWD/$pwd/g;
$$thing =~ s/${prefix}POSIX_PWD/$posix_pwd/g;
$$thing =~ s/${prefix}VERSION/$CURLVERSION/g;
$$thing =~ s/${prefix}TESTNUMBER/$testnum/g;
my $file_pwd = $pwd;
if($file_pwd !~ /^\//) {
$file_pwd = "/$file_pwd";
}
my $ssh_pwd = $posix_pwd;
# this only works after the SSH server has been started
# TODO: call sshversioninfo early and store $sshdid so this substitution
# always works
if ($sshdid && $sshdid =~ /OpenSSH-Windows/) {
$ssh_pwd = $file_pwd;
}
$$thing =~ s/${prefix}FILE_PWD/$file_pwd/g;
$$thing =~ s/${prefix}SSH_PWD/$ssh_pwd/g;
$$thing =~ s/${prefix}SRCDIR/$srcdir/g;
$$thing =~ s/${prefix}USER/$USER/g;
$$thing =~ s/${prefix}SSHSRVMD5/$SSHSRVMD5/g;
$$thing =~ s/${prefix}SSHSRVSHA256/$SSHSRVSHA256/g;
# The purpose of FTPTIME2 and FTPTIME3 is to provide times that can be
# used for time-out tests and that would work on most hosts as these
# adjust for the startup/check time for this particular host. We needed to
# do this to make the test suite run better on very slow hosts.
my $ftp2 = $ftpchecktime * 2;
my $ftp3 = $ftpchecktime * 3;
$$thing =~ s/${prefix}FTPTIME2/$ftp2/g;
$$thing =~ s/${prefix}FTPTIME3/$ftp3/g;
# HTTP2
$$thing =~ s/${prefix}H2CVER/$h2cver/g;
}
1;

143
tests/testutil.pm Normal file
View File

@ -0,0 +1,143 @@
#***************************************************************************
# _ _ ____ _
# Project ___| | | | _ \| |
# / __| | | | |_) | |
# | (__| |_| | _ <| |___
# \___|\___/|_| \_\_____|
#
# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution. The terms
# are also available at https://curl.se/docs/copyright.html.
#
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
# copies of the Software, and permit persons to whom the Software is
# furnished to do so, under the terms of the COPYING file.
#
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
# KIND, either express or implied.
#
# SPDX-License-Identifier: curl
#
###########################################################################
# This module contains miscellanous functions needed in several parts of
# the test suite.
package testutil;
use strict;
use warnings;
BEGIN {
use base qw(Exporter);
our @EXPORT = qw(
runclient
runclientoutput
subbase64
subnewlines
);
}
use MIME::Base64;
use globalconfig qw(
$torture
$verbose
);
sub subbase64 {
my ($thing) = @_;
# cut out the base64 piece
if($$thing =~ s/%b64\[(.*)\]b64%/%%B64%%/i) {
my $d = $1;
# encode %NN characters
$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
my $enc = encode_base64($d, "");
# put the result into there
$$thing =~ s/%%B64%%/$enc/;
}
# hex decode
if($$thing =~ s/%hex\[(.*)\]hex%/%%HEX%%/i) {
# decode %NN characters
my $d = $1;
$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
$$thing =~ s/%%HEX%%/$d/;
}
if($$thing =~ s/%repeat\[(\d+) x (.*)\]%/%%REPEAT%%/i) {
# decode %NN characters
my ($d, $n) = ($2, $1);
$d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
my $all = $d x $n;
$$thing =~ s/%%REPEAT%%/$all/;
}
}
my $prevupdate; # module scope so it remembers the last value
sub subnewlines {
my ($force, $thing) = @_;
if($force) {
# enforce CRLF newline
$$thing =~ s/\x0d*\x0a/\x0d\x0a/;
return;
}
# When curl is built with Hyper, it gets all response headers delivered as
# name/value pairs and curl "invents" the newlines when it saves the
# headers. Therefore, curl will always save headers with CRLF newlines
# when built to use Hyper. By making sure we deliver all tests using CRLF
# as well, all test comparisons will survive without knowing about this
# little quirk.
if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
(($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
# skip curl error messages
($$thing !~ /^curl: \(\d+\) /))) {
# enforce CRLF newline
$$thing =~ s/\x0d*\x0a/\x0d\x0a/;
$prevupdate = 1;
}
else {
if(($$thing =~ /^\n\z/) && $prevupdate) {
# if there's a blank link after a line we update, we hope it is
# the empty line following headers
$$thing =~ s/\x0a/\x0d\x0a/;
}
$prevupdate = 0;
}
}
#######################################################################
# Run the application under test and return its return code
#
sub runclient {
my ($cmd)=@_;
my $ret = system($cmd);
print "CMD ($ret): $cmd\n" if($verbose && !$torture);
return $ret;
# This is one way to test curl on a remote machine
# my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
# sleep 2; # time to allow the NFS server to be updated
# return $out;
}
#######################################################################
# Run the application under test and return its stdout
#
sub runclientoutput {
my ($cmd)=@_;
return `$cmd 2>/dev/null`;
# This is one way to test curl on a remote machine
# my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
# sleep 2; # time to allow the NFS server to be updated
# return @out;
}
1;