218 lines
6.1 KiB
Perl
218 lines
6.1 KiB
Perl
|
#***************************************************************************
|
||
|
|
# _ _ ____ _
|
||
|
|
# 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 miscellaneous 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
|
||
|
|
setlogfunc
|
||
|
|
shell_quote
|
||
|
|
subbase64
|
||
|
|
subnewlines
|
||
|
|
);
|
||
|
|
|
||
|
|
our @EXPORT_OK = qw(
|
||
|
|
clearlogs
|
||
|
|
logmsg
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
use MIME::Base64;
|
||
|
|
|
||
|
|
use globalconfig qw(
|
||
|
|
$torture
|
||
|
|
$verbose
|
||
|
|
);
|
||
|
|
|
||
|
|
my $logfunc; # optional reference to function for logging
|
||
|
|
my @logmessages; # array holding logged messages
|
||
|
|
|
||
|
|
|
||
|
|
#######################################################################
|
||
|
|
# Log an informational message
|
||
|
|
# If a log callback function was set in setlogfunc, it is called. If not,
|
||
|
|
# then the log message is buffered until retrieved by clearlogs.
|
||
|
|
#
|
||
|
|
# logmsg must only be called by one of the runner_* entry points and functions
|
||
|
|
# called by them, or else logs risk being lost, since those are the only
|
||
|
|
# functions that know about and will return buffered logs.
|
||
|
|
sub logmsg {
|
||
|
|
if(!scalar(@_)) {
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
if(defined $logfunc) {
|
||
|
|
&$logfunc(@_);
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
push @logmessages, @_;
|
||
|
|
}
|
||
|
|
|
||
|
|
#######################################################################
|
||
|
|
# Set the function to use for logging
|
||
|
|
sub setlogfunc {
|
||
|
|
($logfunc)=@_;
|
||
|
|
}
|
||
|
|
|
||
|
|
#######################################################################
|
||
|
|
# Clear the buffered log messages after returning them
|
||
|
|
sub clearlogs {
|
||
|
|
my $loglines = join('', @logmessages);
|
||
|
|
undef @logmessages;
|
||
|
|
return $loglines;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#######################################################################
|
||
|
|
|
||
|
|
sub includefile {
|
||
|
|
my ($f) = @_;
|
||
|
|
open(F, "<$f");
|
||
|
|
my @a = <F>;
|
||
|
|
close(F);
|
||
|
|
return join("", @a);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub subbase64 {
|
||
|
|
my ($thing) = @_;
|
||
|
|
|
||
|
|
# cut out the base64 piece
|
||
|
|
while($$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
|
||
|
|
while($$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/;
|
||
|
|
}
|
||
|
|
# repeat
|
||
|
|
while($$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/;
|
||
|
|
}
|
||
|
|
|
||
|
|
# include a file
|
||
|
|
$$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1)/ge;
|
||
|
|
}
|
||
|
|
|
||
|
|
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;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#######################################################################
|
||
|
|
# Quote an argument for passing safely to a Bourne shell
|
||
|
|
# This does the same thing as String::ShellQuote but doesn't need a package.
|
||
|
|
#
|
||
|
|
sub shell_quote {
|
||
|
|
my ($s)=@_;
|
||
|
|
if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) {
|
||
|
|
# string contains a "dangerous" character--quote it
|
||
|
|
$s =~ s/'/'"'"'/g;
|
||
|
|
$s = "'" . $s . "'";
|
||
|
|
}
|
||
|
|
return $s;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|