707f74c04a
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
144 lines
4.2 KiB
Perl
144 lines
4.2 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 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;
|