tests/testutil.pm

   1 #***************************************************************************
   2 #                                  _   _ ____  _
   3 #  Project                     ___| | | |  _ \| |
   4 #                             / __| | | | |_) | |
   5 #                            | (__| |_| |  _ <| |___
   6 #                             \___|\___/|_| \_\_____|
   7 #
   8 # Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
   9 #
  10 # This software is licensed as described in the file COPYING, which
  11 # you should have received as part of this distribution. The terms
  12 # are also available at https://curl.se/docs/copyright.html.
  13 #
  14 # You may opt to use, copy, modify, merge, publish, distribute and/or sell
  15 # copies of the Software, and permit persons to whom the Software is
  16 # furnished to do so, under the terms of the COPYING file.
  17 #
  18 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
  19 # KIND, either express or implied.
  20 #
  21 # SPDX-License-Identifier: curl
  22 #
  23 ###########################################################################
  24
  25 # This module contains miscellaneous functions needed in several parts of
  26 # the test suite.
  27
  28 package testutil;
  29
  30 use strict;
  31 use warnings;
  32
  33 BEGIN {
  34     use base qw(Exporter);
  35
  36     our @EXPORT = qw(
  37         runclient
  38         runclientoutput
  39         setlogfunc
  40         shell_quote
  41         subbase64
  42         subnewlines
  43     );
  44
  45     our @EXPORT_OK = qw(
  46         clearlogs
  47         logmsg
  48     );
  49 }
  50
  51 use MIME::Base64;
  52
  53 use globalconfig qw(
  54     $torture
  55     $verbose
  56 );
  57
  58 my $logfunc;      # optional reference to function for logging
  59 my @logmessages;  # array holding logged messages
  60
  61
  62 #######################################################################
  63 # Log an informational message
  64 # If a log callback function was set in setlogfunc, it is called. If not,
  65 # then the log message is buffered until retrieved by clearlogs.
  66 #
  67 # logmsg must only be called by one of the runner_* entry points and functions
  68 # called by them, or else logs risk being lost, since those are the only
  69 # functions that know about and will return buffered logs.
  70 sub logmsg {
  71     if(!scalar(@_)) {
  72         return;
  73     }
  74     if(defined $logfunc) {
  75         &$logfunc(@_);
  76         return;
  77     }
  78     push @logmessages, @_;
  79 }
  80
  81 #######################################################################
  82 # Set the function to use for logging
  83 sub setlogfunc {
  84     ($logfunc)=@_;
  85 }
  86
  87 #######################################################################
  88 # Clear the buffered log messages after returning them
  89 sub clearlogs {
  90     my $loglines = join('', @logmessages);
  91     undef @logmessages;
  92     return $loglines;
  93 }
  94
  95
  96 #######################################################################
  97 sub subbase64 {
  98     my ($thing) = @_;
  99
 100     # cut out the base64 piece
 101     while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) {
 102         my $d = $1;
 103         # encode %NN characters
 104         $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 105         my $enc = encode_base64($d, "");
 106         # put the result into there
 107         $$thing =~ s/%%B64%%/$enc/;
 108     }
 109     # hex decode
 110     while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) {
 111         # decode %NN characters
 112         my $d = $1;
 113         $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 114         $$thing =~ s/%%HEX%%/$d/;
 115     }
 116     while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) {
 117         # decode %NN characters
 118         my ($d, $n) = ($2, $1);
 119         $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 120         my $all = $d x $n;
 121         $$thing =~ s/%%REPEAT%%/$all/;
 122     }
 123 }
 124
 125 my $prevupdate;  # module scope so it remembers the last value
 126 sub subnewlines {
 127     my ($force, $thing) = @_;
 128
 129     if($force) {
 130         # enforce CRLF newline
 131         $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
 132         return;
 133     }
 134
 135     # When curl is built with Hyper, it gets all response headers delivered as
 136     # name/value pairs and curl "invents" the newlines when it saves the
 137     # headers. Therefore, curl will always save headers with CRLF newlines
 138     # when built to use Hyper. By making sure we deliver all tests using CRLF
 139     # as well, all test comparisons will survive without knowing about this
 140     # little quirk.
 141
 142     if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
 143        ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
 144        (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
 145         # skip curl error messages
 146         ($$thing !~ /^curl: \(\d+\) /))) {
 147         # enforce CRLF newline
 148         $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
 149         $prevupdate = 1;
 150     }
 151     else {
 152         if(($$thing =~ /^\n\z/) && $prevupdate) {
 153             # if there's a blank link after a line we update, we hope it is
 154             # the empty line following headers
 155             $$thing =~ s/\x0a/\x0d\x0a/;
 156         }
 157         $prevupdate = 0;
 158     }
 159 }
 160
 161 #######################################################################
 162 # Run the application under test and return its return code
 163 #
 164 sub runclient {
 165     my ($cmd)=@_;
 166     my $ret = system($cmd);
 167     print "CMD ($ret): $cmd\n" if($verbose && !$torture);
 168     return $ret;
 169
 170 # This is one way to test curl on a remote machine
 171 #    my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
 172 #    sleep 2;    # time to allow the NFS server to be updated
 173 #    return $out;
 174 }
 175
 176 #######################################################################
 177 # Run the application under test and return its stdout
 178 #
 179 sub runclientoutput {
 180     my ($cmd)=@_;
 181     return `$cmd 2>/dev/null`;
 182
 183 # This is one way to test curl on a remote machine
 184 #    my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
 185 #    sleep 2;    # time to allow the NFS server to be updated
 186 #    return @out;
 187 }
 188
 189
 190 #######################################################################
 191 # Quote an argument for passing safely to a Bourne shell
 192 # This does the same thing as String::ShellQuote but doesn't need a package.
 193 #
 194 sub shell_quote {
 195     my ($s)=@_;
 196     if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) {
 197         # string contains a "dangerous" character--quote it
 198         $s =~ s/'/'"'"'/g;
 199         $s = "'" . $s . "'";
 200     }
 201     return $s;
 202 }
 203
 204 1;