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####################################################################### 97sub 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 125my $prevupdate; # module scope so it remembers the last value 126sub 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# 164sub 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# 179sub 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# 194sub 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 2041; 205