master-server/deps/curl/tests/testutil.pm
2024-05-15 15:20:32 -04:00

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;