1#*************************************************************************** 2# _ _ ____ _ 3# Project ___| | | | _ \| | 4# / __| | | | |_) | | 5# | (__| |_| | _ <| |___ 6# \___|\___/|_| \_\_____| 7# 8# Copyright (C) 1998 - 2021, 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########################################################################### 22 23#use strict; 24 25my @xml; 26my $xmlfile; 27 28my $warning=0; 29my $trace=0; 30 31use MIME::Base64; 32 33sub decode_hex { 34 my $s = $_; 35 # remove everything not hex 36 $s =~ s/[^A-Fa-f0-9]//g; 37 # encode everything 38 $s =~ s/([a-fA-F0-9][a-fA-F0-9])/chr(hex($1))/eg; 39 return $s; 40} 41 42sub getpartattr { 43 # if $part is undefined (ie only one argument) then 44 # return the attributes of the section 45 46 my ($section, $part)=@_; 47 48 my %hash; 49 my $inside=0; 50 51 # print "Section: $section, part: $part\n"; 52 53 for(@xml) { 54 # print "$inside: $_"; 55 if(!$inside && ($_ =~ /^ *\<$section/)) { 56 $inside++; 57 } 58 if((1 ==$inside) && ( ($_ =~ /^ *\<$part([^>]*)/) || 59 !(defined($part)) ) 60 ) { 61 $inside++; 62 my $attr=$1; 63 64 while($attr =~ s/ *([^=]*)= *(\"([^\"]*)\"|([^\> ]*))//) { 65 my ($var, $cont)=($1, $2); 66 $cont =~ s/^\"(.*)\"$/$1/; 67 $hash{$var}=$cont; 68 } 69 last; 70 } 71 # detect end of section when part wasn't found 72 elsif((1 ==$inside) && ($_ =~ /^ *\<\/$section\>/)) { 73 last; 74 } 75 elsif((2 ==$inside) && ($_ =~ /^ *\<\/$part/)) { 76 $inside--; 77 } 78 } 79 return %hash; 80} 81 82sub getpart { 83 my ($section, $part)=@_; 84 85 my @this; 86 my $inside=0; 87 my $base64=0; 88 my $hex=0; 89 my $line; 90 91 for(@xml) { 92 $line++; 93 if(!$inside && ($_ =~ /^ *\<$section/)) { 94 $inside++; 95 } 96 elsif(($inside >= 1) && ($_ =~ /^ *\<$part[ \>]/)) { 97 if($inside > 1) { 98 push @this, $_; 99 } 100 elsif($_ =~ /$part [^>]*base64=/) { 101 # attempt to detect our base64 encoded part 102 $base64=1; 103 } 104 elsif($_ =~ /$part [^>]*hex=/) { 105 # attempt to detect a hex-encoded part 106 $hex=1; 107 } 108 $inside++; 109 } 110 elsif(($inside >= 2) && ($_ =~ /^ *\<\/$part[ \>]/)) { 111 if($inside > 2) { 112 push @this, $_; 113 } 114 $inside--; 115 } 116 elsif(($inside >= 1) && ($_ =~ /^ *\<\/$section/)) { 117 if($inside > 1) { 118 print STDERR "$xmlfile:$line:1: error: missing </$part> tag before </$section>\n"; 119 @this = ("format error in $xmlfile"); 120 } 121 if($trace && @this) { 122 print STDERR "*** getpart.pm: $section/$part returned data!\n"; 123 } 124 if($warning && !@this) { 125 print STDERR "*** getpart.pm: $section/$part returned empty!\n"; 126 } 127 if($base64) { 128 # decode the whole array before returning it! 129 for(@this) { 130 my $decoded = decode_base64($_); 131 $_ = $decoded; 132 } 133 } 134 elsif($hex) { 135 # decode the whole array before returning it! 136 for(@this) { 137 my $decoded = decode_hex($_); 138 $_ = $decoded; 139 } 140 } 141 return @this; 142 } 143 elsif($inside >= 2) { 144 push @this, $_; 145 } 146 } 147 if($trace && @this) { 148 # section/part has data but end of section not detected, 149 # end of file implies end of section. 150 print STDERR "*** getpart.pm: $section/$part returned data!\n"; 151 } 152 if($warning && !@this) { 153 # section/part does not exist or has no data without an end of 154 # section; end of file implies end of section. 155 print STDERR "*** getpart.pm: $section/$part returned empty!\n"; 156 } 157 return @this; 158} 159 160sub partexists { 161 my ($section, $part)=@_; 162 163 my $inside = 0; 164 165 for(@xml) { 166 if(!$inside && ($_ =~ /^ *\<$section/)) { 167 $inside++; 168 } 169 elsif((1 == $inside) && ($_ =~ /^ *\<$part[ \>]/)) { 170 return 1; # exists 171 } 172 elsif((1 == $inside) && ($_ =~ /^ *\<\/$section/)) { 173 return 0; # does not exist 174 } 175 } 176 return 0; # does not exist 177} 178 179# Return entire document as list of lines 180sub getall { 181 return @xml; 182} 183 184sub loadtest { 185 my ($file)=@_; 186 187 undef @xml; 188 $xmlfile = $file; 189 190 if(open(XML, "<$file")) { 191 binmode XML; # for crapage systems, use binary 192 while(<XML>) { 193 push @xml, $_; 194 } 195 close(XML); 196 } 197 else { 198 # failure 199 if($warning) { 200 print STDERR "file $file wouldn't open!\n"; 201 } 202 return 1; 203 } 204 return 0; 205} 206 207sub fulltest { 208 return @xml; 209} 210 211# write the test to the given file 212sub savetest { 213 my ($file)=@_; 214 215 if(open(XML, ">$file")) { 216 binmode XML; # for crapage systems, use binary 217 for(@xml) { 218 print XML $_; 219 } 220 close(XML); 221 } 222 else { 223 # failure 224 if($warning) { 225 print STDERR "file $file wouldn't open!\n"; 226 } 227 return 1; 228 } 229 return 0; 230} 231 232# 233# Strip off all lines that match the specified pattern and return 234# the new array. 235# 236 237sub striparray { 238 my ($pattern, $arrayref) = @_; 239 240 my @array; 241 242 for(@$arrayref) { 243 if($_ !~ /$pattern/) { 244 push @array, $_; 245 } 246 } 247 return @array; 248} 249 250# 251# pass array *REFERENCES* ! 252# 253sub compareparts { 254 my ($firstref, $secondref)=@_; 255 256 my $first = join("", @$firstref); 257 my $second = join("", @$secondref); 258 259 # we cannot compare arrays index per index since with the base64 chunks, 260 # they may not be "evenly" distributed 261 262 # NOTE: this no longer strips off carriage returns from the arrays. Is that 263 # really necessary? It ruins the testing of newlines. I believe it was once 264 # added to enable tests on win32. 265 266 if($first ne $second) { 267 return 1; 268 } 269 270 return 0; 271} 272 273# 274# Write a given array to the specified file 275# 276sub writearray { 277 my ($filename, $arrayref)=@_; 278 279 open(TEMP, ">$filename"); 280 binmode(TEMP,":raw"); # cygwin fix by Kevin Roth 281 for(@$arrayref) { 282 print TEMP $_; 283 } 284 close(TEMP); 285} 286 287# 288# Load a specified file and return it as an array 289# 290sub loadarray { 291 my ($filename)=@_; 292 my @array; 293 294 open(TEMP, "<$filename"); 295 while(<TEMP>) { 296 push @array, $_; 297 } 298 close(TEMP); 299 return @array; 300} 301 302# Given two array references, this function will store them in two temporary 303# files, run 'diff' on them, store the result and return the diff output! 304 305sub showdiff { 306 my ($logdir, $firstref, $secondref)=@_; 307 308 my $file1="$logdir/check-generated"; 309 my $file2="$logdir/check-expected"; 310 311 open(TEMP, ">$file1"); 312 for(@$firstref) { 313 my $l = $_; 314 $l =~ s/\r/[CR]/g; 315 $l =~ s/\n/[LF]/g; 316 $l =~ s/([^\x20-\x7f])/sprintf "%%%02x", ord $1/eg; 317 print TEMP $l; 318 print TEMP "\n"; 319 } 320 close(TEMP); 321 322 open(TEMP, ">$file2"); 323 for(@$secondref) { 324 my $l = $_; 325 $l =~ s/\r/[CR]/g; 326 $l =~ s/\n/[LF]/g; 327 $l =~ s/([^\x20-\x7f])/sprintf "%%%02x", ord $1/eg; 328 print TEMP $l; 329 print TEMP "\n"; 330 } 331 close(TEMP); 332 my @out = `diff -u $file2 $file1 2>/dev/null`; 333 334 if(!$out[0]) { 335 @out = `diff -c $file2 $file1 2>/dev/null`; 336 } 337 338 return @out; 339} 340 341 3421; 343