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