2
0

getpart.pm 8.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359
  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. package getpart;
  25. use strict;
  26. use warnings;
  27. BEGIN {
  28. use base qw(Exporter);
  29. our @EXPORT = qw(
  30. compareparts
  31. fulltest
  32. getpart
  33. getpartattr
  34. loadarray
  35. loadtest
  36. partexists
  37. striparray
  38. writearray
  39. );
  40. }
  41. use Memoize;
  42. use MIME::Base64;
  43. my @xml; # test data file contents
  44. my $xmlfile; # test data file name
  45. my $warning=0;
  46. my $trace=0;
  47. # Normalize the part function arguments for proper caching. This includes the
  48. # file name in the arguments since that is an implied parameter that affects the
  49. # return value. Any error messages will only be displayed the first time, but
  50. # those are disabled by default anyway, so should never been seen outside
  51. # development.
  52. sub normalize_part {
  53. push @_, $xmlfile;
  54. return join("\t", @_);
  55. }
  56. sub decode_hex {
  57. my $s = $_;
  58. # remove everything not hex
  59. $s =~ s/[^A-Fa-f0-9]//g;
  60. # encode everything
  61. $s =~ s/([a-fA-F0-9][a-fA-F0-9])/chr(hex($1))/eg;
  62. return $s;
  63. }
  64. sub testcaseattr {
  65. my %hash;
  66. for(@xml) {
  67. if(($_ =~ /^ *\<testcase ([^>]*)/)) {
  68. my $attr=$1;
  69. while($attr =~ s/ *([^=]*)= *(\"([^\"]*)\"|([^\> ]*))//) {
  70. my ($var, $cont)=($1, $2);
  71. $cont =~ s/^\"(.*)\"$/$1/;
  72. $hash{$var}=$cont;
  73. }
  74. }
  75. }
  76. return %hash;
  77. }
  78. sub getpartattr {
  79. # if $part is undefined (ie only one argument) then
  80. # return the attributes of the section
  81. my ($section, $part)=@_;
  82. my %hash;
  83. my $inside=0;
  84. # print "Section: $section, part: $part\n";
  85. for(@xml) {
  86. # print "$inside: $_";
  87. if(!$inside && ($_ =~ /^ *\<$section/)) {
  88. $inside++;
  89. }
  90. if((1 ==$inside) && ( ($_ =~ /^ *\<$part ([^>]*)/) ||
  91. !(defined($part)) )
  92. ) {
  93. $inside++;
  94. my $attr=$1;
  95. while($attr =~ s/ *([^=]*)= *(\"([^\"]*)\"|([^\> ]*))//) {
  96. my ($var, $cont)=($1, $2);
  97. $cont =~ s/^\"(.*)\"$/$1/;
  98. $hash{$var}=$cont;
  99. }
  100. last;
  101. }
  102. # detect end of section when part wasn't found
  103. elsif((1 ==$inside) && ($_ =~ /^ *\<\/$section\>/)) {
  104. last;
  105. }
  106. elsif((2 ==$inside) && ($_ =~ /^ *\<\/$part/)) {
  107. $inside--;
  108. }
  109. }
  110. return %hash;
  111. }
  112. memoize('getpartattr', NORMALIZER => 'normalize_part'); # cache each result
  113. sub getpart {
  114. my ($section, $part)=@_;
  115. my @this;
  116. my $inside=0;
  117. my $base64=0;
  118. my $hex=0;
  119. my $line;
  120. for(@xml) {
  121. $line++;
  122. if(!$inside && ($_ =~ /^ *\<$section/)) {
  123. $inside++;
  124. }
  125. elsif(($inside >= 1) && ($_ =~ /^ *\<$part[ \>]/)) {
  126. if($inside > 1) {
  127. push @this, $_;
  128. }
  129. elsif($_ =~ /$part [^>]*base64=/) {
  130. # attempt to detect our base64 encoded part
  131. $base64=1;
  132. }
  133. elsif($_ =~ /$part [^>]*hex=/) {
  134. # attempt to detect a hex-encoded part
  135. $hex=1;
  136. }
  137. $inside++;
  138. }
  139. elsif(($inside >= 2) && ($_ =~ /^ *\<\/$part[ \>]/)) {
  140. if($inside > 2) {
  141. push @this, $_;
  142. }
  143. $inside--;
  144. }
  145. elsif(($inside >= 1) && ($_ =~ /^ *\<\/$section/)) {
  146. if($inside > 1) {
  147. print STDERR "$xmlfile:$line:1: error: missing </$part> tag before </$section>\n";
  148. @this = ("format error in $xmlfile");
  149. }
  150. if($trace && @this) {
  151. print STDERR "*** getpart.pm: $section/$part returned data!\n";
  152. }
  153. if($warning && !@this) {
  154. print STDERR "*** getpart.pm: $section/$part returned empty!\n";
  155. }
  156. if($base64) {
  157. # decode the whole array before returning it!
  158. for(@this) {
  159. my $decoded = decode_base64($_);
  160. $_ = $decoded;
  161. }
  162. }
  163. elsif($hex) {
  164. # decode the whole array before returning it!
  165. for(@this) {
  166. my $decoded = decode_hex($_);
  167. $_ = $decoded;
  168. }
  169. }
  170. return @this;
  171. }
  172. elsif($inside >= 2) {
  173. push @this, $_;
  174. }
  175. }
  176. if($trace && @this) {
  177. # section/part has data but end of section not detected,
  178. # end of file implies end of section.
  179. print STDERR "*** getpart.pm: $section/$part returned data!\n";
  180. }
  181. if($warning && !@this) {
  182. # section/part does not exist or has no data without an end of
  183. # section; end of file implies end of section.
  184. print STDERR "*** getpart.pm: $section/$part returned empty!\n";
  185. }
  186. return @this;
  187. }
  188. memoize('getpart', NORMALIZER => 'normalize_part'); # cache each result
  189. sub partexists {
  190. my ($section, $part)=@_;
  191. my $inside = 0;
  192. for(@xml) {
  193. if(!$inside && ($_ =~ /^ *\<$section/)) {
  194. $inside++;
  195. }
  196. elsif((1 == $inside) && ($_ =~ /^ *\<$part[ \>]/)) {
  197. return 1; # exists
  198. }
  199. elsif((1 == $inside) && ($_ =~ /^ *\<\/$section/)) {
  200. return 0; # does not exist
  201. }
  202. }
  203. return 0; # does not exist
  204. }
  205. # The code currently never calls this more than once per part per file, so
  206. # caching a result that will never be used again just slows things down.
  207. # memoize('partexists', NORMALIZER => 'normalize_part'); # cache each result
  208. sub loadtest {
  209. my ($file)=@_;
  210. if(defined $xmlfile && $file eq $xmlfile) {
  211. # This test is already loaded
  212. return
  213. }
  214. undef @xml;
  215. $xmlfile = "";
  216. if(open(my $xmlh, "<", "$file")) {
  217. binmode $xmlh; # for crapage systems, use binary
  218. while(<$xmlh>) {
  219. push @xml, $_;
  220. }
  221. close($xmlh);
  222. }
  223. else {
  224. # failure
  225. if($warning) {
  226. print STDERR "file $file wouldn't open!\n";
  227. }
  228. return 1;
  229. }
  230. $xmlfile = $file;
  231. return 0;
  232. }
  233. # Return entire document as list of lines
  234. sub fulltest {
  235. return @xml;
  236. }
  237. # write the test to the given file
  238. sub savetest {
  239. my ($file)=@_;
  240. if(open(my $xmlh, ">", "$file")) {
  241. binmode $xmlh; # for crapage systems, use binary
  242. for(@xml) {
  243. print $xmlh $_;
  244. }
  245. close($xmlh);
  246. }
  247. else {
  248. # failure
  249. if($warning) {
  250. print STDERR "file $file wouldn't open!\n";
  251. }
  252. return 1;
  253. }
  254. return 0;
  255. }
  256. #
  257. # Strip off all lines that match the specified pattern and return
  258. # the new array.
  259. #
  260. sub striparray {
  261. my ($pattern, $arrayref) = @_;
  262. my @array;
  263. for(@$arrayref) {
  264. if($_ !~ /$pattern/) {
  265. push @array, $_;
  266. }
  267. }
  268. return @array;
  269. }
  270. #
  271. # pass array *REFERENCES* !
  272. #
  273. sub compareparts {
  274. my ($firstref, $secondref)=@_;
  275. my $first = join("", @$firstref);
  276. my $second = join("", @$secondref);
  277. # we cannot compare arrays index per index since with the base64 chunks,
  278. # they may not be "evenly" distributed
  279. # NOTE: this no longer strips off carriage returns from the arrays. Is that
  280. # really necessary? It ruins the testing of newlines. I believe it was once
  281. # added to enable tests on win32.
  282. if($first ne $second) {
  283. return 1;
  284. }
  285. return 0;
  286. }
  287. #
  288. # Write a given array to the specified file
  289. #
  290. sub writearray {
  291. my ($filename, $arrayref)=@_;
  292. open(my $temp, ">", "$filename") || die "Failure writing file";
  293. binmode($temp,":raw"); # cygwin fix by Kevin Roth
  294. for(@$arrayref) {
  295. print $temp $_;
  296. }
  297. close($temp) || die "Failure writing file";
  298. }
  299. #
  300. # Load a specified file and return it as an array
  301. #
  302. sub loadarray {
  303. my ($filename)=@_;
  304. my @array;
  305. if (open(my $temp, "<", "$filename")) {
  306. while(<$temp>) {
  307. push @array, $_;
  308. }
  309. close($temp);
  310. }
  311. return @array;
  312. }
  313. 1;