tests/getpart.pm

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