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