2
0

testutil.pm 5.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204
  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 subbase64 {
  83. my ($thing) = @_;
  84. # cut out the base64 piece
  85. while($$thing =~ s/%b64\[(.*?)\]b64%/%%B64%%/i) {
  86. my $d = $1;
  87. # encode %NN characters
  88. $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  89. my $enc = encode_base64($d, "");
  90. # put the result into there
  91. $$thing =~ s/%%B64%%/$enc/;
  92. }
  93. # hex decode
  94. while($$thing =~ s/%hex\[(.*?)\]hex%/%%HEX%%/i) {
  95. # decode %NN characters
  96. my $d = $1;
  97. $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  98. $$thing =~ s/%%HEX%%/$d/;
  99. }
  100. while($$thing =~ s/%repeat\[(\d+) x (.*?)\]%/%%REPEAT%%/i) {
  101. # decode %NN characters
  102. my ($d, $n) = ($2, $1);
  103. $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  104. my $all = $d x $n;
  105. $$thing =~ s/%%REPEAT%%/$all/;
  106. }
  107. }
  108. my $prevupdate; # module scope so it remembers the last value
  109. sub subnewlines {
  110. my ($force, $thing) = @_;
  111. if($force) {
  112. # enforce CRLF newline
  113. $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
  114. return;
  115. }
  116. # When curl is built with Hyper, it gets all response headers delivered as
  117. # name/value pairs and curl "invents" the newlines when it saves the
  118. # headers. Therefore, curl will always save headers with CRLF newlines
  119. # when built to use Hyper. By making sure we deliver all tests using CRLF
  120. # as well, all test comparisons will survive without knowing about this
  121. # little quirk.
  122. if(($$thing =~ /^HTTP\/(1.1|1.0|2|3) [1-5][^\x0d]*\z/) ||
  123. ($$thing =~ /^(GET|POST|PUT|DELETE) \S+ HTTP\/\d+(\.\d+)?/) ||
  124. (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
  125. # skip curl error messages
  126. ($$thing !~ /^curl: \(\d+\) /))) {
  127. # enforce CRLF newline
  128. $$thing =~ s/\x0d*\x0a/\x0d\x0a/;
  129. $prevupdate = 1;
  130. }
  131. else {
  132. if(($$thing =~ /^\n\z/) && $prevupdate) {
  133. # if there's a blank link after a line we update, we hope it is
  134. # the empty line following headers
  135. $$thing =~ s/\x0a/\x0d\x0a/;
  136. }
  137. $prevupdate = 0;
  138. }
  139. }
  140. #######################################################################
  141. # Run the application under test and return its return code
  142. #
  143. sub runclient {
  144. my ($cmd)=@_;
  145. my $ret = system($cmd);
  146. print "CMD ($ret): $cmd\n" if($verbose && !$torture);
  147. return $ret;
  148. # This is one way to test curl on a remote machine
  149. # my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
  150. # sleep 2; # time to allow the NFS server to be updated
  151. # return $out;
  152. }
  153. #######################################################################
  154. # Run the application under test and return its stdout
  155. #
  156. sub runclientoutput {
  157. my ($cmd)=@_;
  158. return `$cmd 2>/dev/null`;
  159. # This is one way to test curl on a remote machine
  160. # my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
  161. # sleep 2; # time to allow the NFS server to be updated
  162. # return @out;
  163. }
  164. #######################################################################
  165. # Quote an argument for passing safely to a Bourne shell
  166. # This does the same thing as String::ShellQuote but doesn't need a package.
  167. #
  168. sub shell_quote {
  169. my ($s)=@_;
  170. if($s !~ m/^[-+=.,_\/:a-zA-Z0-9]+$/) {
  171. # string contains a "dangerous" character--quote it
  172. $s =~ s/'/'"'"'/g;
  173. $s = "'" . $s . "'";
  174. }
  175. return $s;
  176. }
  177. 1;