2
0

testutil.pm 6.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217
  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. # This module contains miscellaneous functions needed in several parts of
  25. # the test suite.
  26. package testutil;
  27. use strict;
  28. use warnings;
  29. BEGIN {
  30. use base qw(Exporter);
  31. our @EXPORT = qw(
  32. runclient
  33. runclientoutput
  34. setlogfunc
  35. shell_quote
  36. subbase64
  37. subnewlines
  38. );
  39. our @EXPORT_OK = qw(
  40. clearlogs
  41. logmsg
  42. );
  43. }
  44. use MIME::Base64;
  45. use globalconfig qw(
  46. $torture
  47. $verbose
  48. );
  49. my $logfunc; # optional reference to function for logging
  50. my @logmessages; # array holding logged messages
  51. #######################################################################
  52. # Log an informational message
  53. # If a log callback function was set in setlogfunc, it is called. If not,
  54. # then the log message is buffered until retrieved by clearlogs.
  55. #
  56. # logmsg must only be called by one of the runner_* entry points and functions
  57. # called by them, or else logs risk being lost, since those are the only
  58. # functions that know about and will return buffered logs.
  59. sub logmsg {
  60. if(!scalar(@_)) {
  61. return;
  62. }
  63. if(defined $logfunc) {
  64. &$logfunc(@_);
  65. return;
  66. }
  67. push @logmessages, @_;
  68. }
  69. #######################################################################
  70. # Set the function to use for logging
  71. sub setlogfunc {
  72. ($logfunc)=@_;
  73. }
  74. #######################################################################
  75. # Clear the buffered log messages after returning them
  76. sub clearlogs {
  77. my $loglines = join('', @logmessages);
  78. undef @logmessages;
  79. return $loglines;
  80. }
  81. #######################################################################
  82. sub includefile {
  83. my ($f) = @_;
  84. open(F, "<$f");
  85. my @a = <F>;
  86. close(F);
  87. return join("", @a);
  88. }
  89. sub subbase64 {
  90. my ($thing) = @_;
  91. # cut out the base64 piece
  92. while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) {
  93. my $d = $1;
  94. # encode %NN characters
  95. $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  96. my $enc = encode_base64($d, "");
  97. # put the result into there
  98. $$thing =~ s/%%B64%%/$enc/;
  99. }
  100. # hex decode
  101. while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) {
  102. # decode %NN characters
  103. my $d = $1;
  104. $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  105. $$thing =~ s/%%HEX%%/$d/;
  106. }
  107. # repeat
  108. while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) {
  109. # decode %NN characters
  110. my ($d, $n) = ($2, $1);
  111. $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  112. my $all = $d x $n;
  113. $$thing =~ s/%%REPEAT%%/$all/;
  114. }
  115. # include a file
  116. $$thing =~ s/%include ([^%]*)%[\n\r]+/includefile($1)/ge;
  117. }
  118. my $prevupdate; # module scope so it remembers the last value
  119. sub subnewlines {
  120. my ($force, $thing) = @_;
  121. if($force) {
  122. # enforce CRLF newline
  123. $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
  124. return;
  125. }
  126. # When curl is built with Hyper, it gets all response headers delivered as
  127. # name/value pairs and curl "invents" the newlines when it saves the
  128. # headers. Therefore, curl will always save headers with CRLF newlines
  129. # when built to use Hyper. By making sure we deliver all tests using CRLF
  130. # as well, all test comparisons will survive without knowing about this
  131. # little quirk.
  132. if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
  133. ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
  134. (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
  135. # skip curl error messages
  136. ($$thing !~ /^curl: \(\d+\) /))) {
  137. # enforce CRLF newline
  138. $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
  139. $prevupdate = 1;
  140. }
  141. else {
  142. if(($$thing =~ /^\n\z/) && $prevupdate) {
  143. # if there's a blank link after a line we update, we hope it is
  144. # the empty line following headers
  145. $$thing =~ s/\x0a/\x0d\x0a/;
  146. }
  147. $prevupdate = 0;
  148. }
  149. }
  150. #######################################################################
  151. # Run the application under test and return its return code
  152. #
  153. sub runclient {
  154. my ($cmd)=@_;
  155. my $ret = system($cmd);
  156. print "CMD ($ret): $cmd\n" if($verbose && !$torture);
  157. return $ret;
  158. # This is one way to test curl on a remote machine
  159. # my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
  160. # sleep 2; # time to allow the NFS server to be updated
  161. # return $out;
  162. }
  163. #######################################################################
  164. # Run the application under test and return its stdout
  165. #
  166. sub runclientoutput {
  167. my ($cmd)=@_;
  168. return `$cmd 2>/dev/null`;
  169. # This is one way to test curl on a remote machine
  170. # my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
  171. # sleep 2; # time to allow the NFS server to be updated
  172. # return @out;
  173. }
  174. #######################################################################
  175. # Quote an argument for passing safely to a Bourne shell
  176. # This does the same thing as String::ShellQuote but doesn't need a package.
  177. #
  178. sub shell_quote {
  179. my ($s)=@_;
  180. if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) {
  181. # string contains a "dangerous" character--quote it
  182. $s =~ s/'/'"'"'/g;
  183. $s = "'" . $s . "'";
  184. }
  185. return $s;
  186. }
  187. 1;