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