testutil.pm (7909B)
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 exerunner 41 shell_quote 42 subbase64 43 subnewlines 44 subsha256base64file 45 substrippemfile 46 ); 47 48 our @EXPORT_OK = qw( 49 clearlogs 50 logmsg 51 ); 52 } 53 54 use Digest::SHA qw(sha256); 55 use MIME::Base64; 56 57 use globalconfig qw( 58 $torture 59 $verbose 60 $dev_null 61 ); 62 63 my $logfunc; # optional reference to function for logging 64 my @logmessages; # array holding logged messages 65 66 67 ####################################################################### 68 # Log an informational message 69 # If a log callback function was set in setlogfunc, it is called. If not, 70 # then the log message is buffered until retrieved by clearlogs. 71 # 72 # logmsg must only be called by one of the runner_* entry points and functions 73 # called by them, or else logs risk being lost, since those are the only 74 # functions that know about and will return buffered logs. 75 sub logmsg { 76 if(!scalar(@_)) { 77 return; 78 } 79 if(defined $logfunc) { 80 &$logfunc(@_); 81 return; 82 } 83 push @logmessages, @_; 84 } 85 86 ####################################################################### 87 # Set the function to use for logging 88 sub setlogfunc { 89 ($logfunc)=@_; 90 } 91 92 ####################################################################### 93 # Clear the buffered log messages after returning them 94 sub clearlogs { 95 my $loglines = join('', @logmessages); 96 undef @logmessages; 97 return $loglines; 98 } 99 100 101 ####################################################################### 102 103 sub includefile { 104 my ($f) = @_; 105 open(F, "<$f"); 106 my @a = <F>; 107 close(F); 108 return join("", @a); 109 } 110 111 sub subbase64 { 112 my ($thing) = @_; 113 114 # cut out the base64 piece 115 while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) { 116 my $d = $1; 117 # encode %NN characters 118 $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 119 my $enc = encode_base64($d, ""); 120 # put the result into there 121 $$thing =~ s/%%B64%%/$enc/; 122 } 123 # hex decode 124 while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) { 125 # decode %NN characters 126 my $d = $1; 127 $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 128 $$thing =~ s/%%HEX%%/$d/; 129 } 130 # repeat 131 while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) { 132 # decode %NN characters 133 my ($d, $n) = ($2, $1); 134 $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 135 $n =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 136 my $all = $d x $n; 137 $$thing =~ s/%%REPEAT%%/$all/; 138 } 139 140 # days 141 while($$thing =~ s/%days\[(.*?)\]/%%DAYS%%/i) { 142 # convert to now + given days in epoch seconds, align to a 60 second 143 # boundary. Then provide two alternatives. 144 my $now = time(); 145 my $d = ($1 * 24 * 3600) + $now + 30; 146 $d = int($d/60) * 60; 147 my $d2 = $d + 60; 148 $$thing =~ s/%%DAYS%%/%alternatives[$d,$d2]/; 149 } 150 151 # include a file 152 $$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1)/ge; 153 } 154 155 my $prevupdate; # module scope so it remembers the last value 156 sub subnewlines { 157 my ($force, $thing) = @_; 158 159 if($force) { 160 # enforce CRLF newline 161 $$thing =~ s/\x0d*\x0a/\x0d\x0a/; 162 return; 163 } 164 165 if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) || 166 ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) || 167 (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) && 168 # skip curl error messages 169 ($$thing !~ /^curl: \(\d+\) /))) { 170 # enforce CRLF newline 171 $$thing =~ s/\x0d*\x0a/\x0d\x0a/; 172 $prevupdate = 1; 173 } 174 else { 175 if(($$thing =~ /^\n\z/) && $prevupdate) { 176 # if there's a blank link after a line we update, we hope it is 177 # the empty line following headers 178 $$thing =~ s/\x0a/\x0d\x0a/; 179 } 180 $prevupdate = 0; 181 } 182 } 183 184 ####################################################################### 185 # Run the application under test and return its return code 186 # 187 sub runclient { 188 my ($cmd)=@_; 189 my $ret = system($cmd); 190 print "CMD ($ret): $cmd\n" if($verbose && !$torture); 191 return $ret; 192 193 # This is one way to test curl on a remote machine 194 # my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'"); 195 # sleep 2; # time to allow the NFS server to be updated 196 # return $out; 197 } 198 199 ####################################################################### 200 # Run the application under test and return its stdout 201 # 202 sub runclientoutput { 203 my ($cmd)=@_; 204 return `$cmd 2>$dev_null`; 205 206 # This is one way to test curl on a remote machine 207 # my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`; 208 # sleep 2; # time to allow the NFS server to be updated 209 # return @out; 210 } 211 212 ####################################################################### 213 # Return custom tool (e.g. wine or qemu) to run curl binaries. 214 # 215 sub exerunner { 216 if($ENV{'CURL_TEST_EXE_RUNNER'}) { 217 return $ENV{'CURL_TEST_EXE_RUNNER'} . ' '; 218 } 219 return ''; 220 } 221 222 ####################################################################### 223 # Quote an argument for passing safely to a Bourne shell 224 # This does the same thing as String::ShellQuote but doesn't need a package. 225 # 226 sub shell_quote { 227 my ($s)=@_; 228 if($^O eq 'MSWin32') { 229 $s = '"' . $s . '"'; 230 } 231 else { 232 if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) { 233 # string contains a "dangerous" character--quote it 234 $s =~ s/'/'"'"'/g; 235 $s = "'" . $s . "'"; 236 } 237 } 238 return $s; 239 } 240 241 sub get_sha256_base64 { 242 my ($file_path) = @_; 243 return encode_base64(sha256(do { local $/; open my $fh, '<:raw', $file_path or die $!; <$fh> }), ""); 244 } 245 246 sub subsha256base64file { 247 my ($thing) = @_; 248 249 # SHA-256 base64 250 while($$thing =~ s/%sha256b64file\[(.*?)\]sha256b64file%/%%SHA256B64FILE%%/i) { 251 my $file_path = $1; 252 $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 253 my $hash_b64 = get_sha256_base64($file_path); 254 $$thing =~ s/%%SHA256B64FILE%%/$hash_b64/; 255 } 256 } 257 258 sub get_file_content { 259 my ($file_path) = @_; 260 my $content = do { local $/; open my $fh, '<', $file_path or die $!; <$fh> }; 261 $content =~ s/(^|-----END .*?-----[\r\n]?)(.*?)(-----BEGIN .*?-----|$)/$1$3/gs; 262 $content =~ s/\r\n/\n/g; 263 chomp($content); 264 return $content; 265 } 266 267 sub substrippemfile { 268 my ($thing) = @_; 269 270 # File content substitution 271 while($$thing =~ s/%strippemfile\[(.*?)\]strippemfile%/%%FILE%%/i) { 272 my $file_path = $1; 273 $file_path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 274 my $file_content = get_file_content($file_path); 275 $$thing =~ s/%%FILE%%/$file_content/; 276 } 277 } 278 1;