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 28package testutil; 29 30use strict; 31use warnings; 32 33BEGIN { 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 51use MIME::Base64; 52 53use globalconfig qw( 54 $torture 55 $verbose 56); 57 58my $logfunc; # optional reference to function for logging 59my @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. 70sub 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 83sub setlogfunc { 84 ($logfunc)=@_; 85} 86 87####################################################################### 88# Clear the buffered log messages after returning them 89sub clearlogs { 90 my $loglines = join('', @logmessages); 91 undef @logmessages; 92 return $loglines; 93} 94 95 96####################################################################### 97 98sub includefile { 99 my ($f) = @_; 100 open(F, "<$f"); 101 my @a = <F>; 102 close(F); 103 return join("", @a); 104} 105 106sub subbase64 { 107 my ($thing) = @_; 108 109 # cut out the base64 piece 110 while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) { 111 my $d = $1; 112 # encode %NN characters 113 $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 114 my $enc = encode_base64($d, ""); 115 # put the result into there 116 $$thing =~ s/%%B64%%/$enc/; 117 } 118 # hex decode 119 while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) { 120 # decode %NN characters 121 my $d = $1; 122 $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 123 $$thing =~ s/%%HEX%%/$d/; 124 } 125 # repeat 126 while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) { 127 # decode %NN characters 128 my ($d, $n) = ($2, $1); 129 $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 130 my $all = $d x $n; 131 $$thing =~ s/%%REPEAT%%/$all/; 132 } 133 134 # include a file 135 $$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1)/ge; 136} 137 138my $prevupdate; # module scope so it remembers the last value 139sub subnewlines { 140 my ($force, $thing) = @_; 141 142 if($force) { 143 # enforce CRLF newline 144 $$thing =~ s/\x0d*\x0a/\x0d\x0a/; 145 return; 146 } 147 148 # When curl is built with Hyper, it gets all response headers delivered as 149 # name/value pairs and curl "invents" the newlines when it saves the 150 # headers. Therefore, curl will always save headers with CRLF newlines 151 # when built to use Hyper. By making sure we deliver all tests using CRLF 152 # as well, all test comparisons will survive without knowing about this 153 # little quirk. 154 155 if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) || 156 ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) || 157 (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) && 158 # skip curl error messages 159 ($$thing !~ /^curl: \(\d+\) /))) { 160 # enforce CRLF newline 161 $$thing =~ s/\x0d*\x0a/\x0d\x0a/; 162 $prevupdate = 1; 163 } 164 else { 165 if(($$thing =~ /^\n\z/) && $prevupdate) { 166 # if there's a blank link after a line we update, we hope it is 167 # the empty line following headers 168 $$thing =~ s/\x0a/\x0d\x0a/; 169 } 170 $prevupdate = 0; 171 } 172} 173 174####################################################################### 175# Run the application under test and return its return code 176# 177sub runclient { 178 my ($cmd)=@_; 179 my $ret = system($cmd); 180 print "CMD ($ret): $cmd\n" if($verbose && !$torture); 181 return $ret; 182 183# This is one way to test curl on a remote machine 184# my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'"); 185# sleep 2; # time to allow the NFS server to be updated 186# return $out; 187} 188 189####################################################################### 190# Run the application under test and return its stdout 191# 192sub runclientoutput { 193 my ($cmd)=@_; 194 return `$cmd 2>/dev/null`; 195 196# This is one way to test curl on a remote machine 197# my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`; 198# sleep 2; # time to allow the NFS server to be updated 199# return @out; 200} 201 202 203####################################################################### 204# Quote an argument for passing safely to a Bourne shell 205# This does the same thing as String::ShellQuote but doesn't need a package. 206# 207sub shell_quote { 208 my ($s)=@_; 209 if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) { 210 # string contains a "dangerous" character--quote it 211 $s =~ s/'/'"'"'/g; 212 $s = "'" . $s . "'"; 213 } 214 return $s; 215} 216 2171; 218
