tests/getpart.pm

   1
   2 #use strict;
   3
   4 my @xml;
   5
   6 my $warning=0;
   7 my $trace=0;
   8
   9 sub decode_base64 {
  10   tr:A-Za-z0-9+/::cd;                   # remove non-base64 chars
  11   tr:A-Za-z0-9+/: -_:;                  # convert to uuencoded format
  12   my $len = pack("c", 32 + 0.75*length);   # compute length byte
  13   return unpack("u", $len . $_);         # uudecode and print
  14 }
  15
  16 sub getpartattr {
  17     # if $part is undefined (ie only one argument) then
  18     # return the attributes of the section
  19
  20     my ($section, $part)=@_;
  21
  22     my %hash;
  23     my $inside=0;
  24
  25  #   print "Section: $section, part: $part\n";
  26
  27     for(@xml) {
  28  #       print "$inside: $_";
  29         if(!$inside && ($_ =~ /^ *\<$section/)) {
  30             $inside++;
  31         }
  32         if((1 ==$inside) && ( ($_ =~ /^ *\<$part([^>]*)/) ||
  33                               !(defined($part)) )
  34              ) {
  35             $inside++;
  36             my $attr=$1;
  37
  38             while($attr =~ s/ *([^=]*)= *(\"([^\"]*)\"|([^\"> ]*))//) {
  39                 my ($var, $cont)=($1, $2);
  40                 $cont =~ s/^\"(.*)\"$/$1/;
  41                 $hash{$var}=$cont;
  42             }
  43             last;
  44         }
  45         elsif((2 ==$inside) && ($_ =~ /^ *\<\/$part/)) {
  46             $inside--;
  47         }
  48     }
  49     return %hash;
  50 }
  51
  52 sub getpart {
  53     my ($section, $part)=@_;
  54
  55     my @this;
  56     my $inside=0;
  57     my $base64=0;
  58
  59  #   print "Section: $section, part: $part\n";
  60
  61     for(@xml) {
  62  #       print "$inside: $_";
  63         if(!$inside && ($_ =~ /^ *\<$section/)) {
  64             $inside++;
  65         }
  66         elsif((1 ==$inside) && ($_ =~ /^ *\<$part[ \>]/)) {
  67             if($_ =~ /$part [^>]*base64=/) {
  68                 # attempt to detect base64 encoded parts
  69                 $base64=1;
  70             }
  71             $inside++;
  72         }
  73         elsif((2 ==$inside) && ($_ =~ /^ *\<\/$part/)) {
  74             $inside--;
  75         }
  76         elsif((1==$inside) && ($_ =~ /^ *\<\/$section/)) {
  77             if($trace) {
  78                 print STDERR "*** getpart.pm: $section/$part returned data!\n";
  79             }
  80             if(!@this && $warning) {
  81                 print STDERR "*** getpart.pm: $section/$part returned empty!\n";
  82             }
  83             if($base64) {
  84                 # decode the whole array before returning it!
  85                 for(@this) {
  86                     my $decoded = decode_base64($_);
  87                     $_ = $decoded;
  88                 }
  89             }
  90             return @this;
  91         }
  92         elsif(2==$inside) {
  93             push @this, $_;
  94         }
  95     }
  96     if($warning) {
  97         print STDERR "*** getpart.pm: $section/$part returned empty!\n";
  98     }
  99     return @this; #empty!
 100 }
 101
 102 sub loadtest {
 103     my ($file)=@_;
 104
 105     undef @xml;
 106
 107     if(open(XML, "<$file")) {
 108         binmode XML; # for crapage systems, use binary
 109         while(<XML>) {
 110             push @xml, $_;
 111         }
 112         close(XML);
 113     }
 114     else {
 115         # failure
 116         if($warning) {
 117             print STDERR "file $file wouldn't open!\n";
 118         }
 119         return 1;
 120     }
 121     return 0;
 122 }
 123
 124 #
 125 # Strip off all lines that match the specified pattern and return
 126 # the new array.
 127 #
 128
 129 sub striparray {
 130     my ($pattern, $arrayref) = @_;
 131
 132     my @array;
 133
 134     for(@$arrayref) {
 135         if($_ !~ /$pattern/) {
 136             push @array, $_;
 137         }
 138     }
 139     return @array;
 140 }
 141
 142 #
 143 # pass array *REFERENCES* !
 144 #
 145 sub compareparts {
 146  my ($firstref, $secondref)=@_;
 147
 148  my $first = join("", @$firstref);
 149  my $second = join("", @$secondref);
 150
 151  # we cannot compare arrays index per index since with the base64 chunks,
 152  # they may not be "evenly" distributed
 153
 154  # NOTE: this no longer strips off carriage returns from the arrays. Is that
 155  # really necessary? It ruins the testing of newlines. I believe it was once
 156  # added to enable tests on win32.
 157
 158  if($first ne $second) {
 159      return 1;
 160  }
 161
 162  return 0;
 163 }
 164
 165 #
 166 # Write a given array to the specified file
 167 #
 168 sub writearray {
 169     my ($filename, $arrayref)=@_;
 170
 171     open(TEMP, ">$filename");
 172     binmode(TEMP,":raw"); # cygwin fix by Kevin Roth
 173     for(@$arrayref) {
 174         print TEMP $_;
 175     }
 176     close(TEMP);
 177 }
 178
 179 #
 180 # Load a specified file an return it as an array
 181 #
 182 sub loadarray {
 183     my ($filename)=@_;
 184     my @array;
 185
 186     open(TEMP, "<$filename");
 187     while(<TEMP>) {
 188         push @array, $_;
 189     }
 190     close(TEMP);
 191     return @array;
 192 }
 193
 194 # Given two array references, this function will store them in two temporary
 195 # files, run 'diff' on them, store the result and return the diff output!
 196
 197 sub showdiff {
 198     my ($logdir, $firstref, $secondref)=@_;
 199
 200     my $file1="$logdir/check-generated";
 201     my $file2="$logdir/check-expected";
 202
 203     open(TEMP, ">$file1");
 204     for(@$firstref) {
 205         print TEMP $_;
 206     }
 207     close(TEMP);
 208
 209     open(TEMP, ">$file2");
 210     for(@$secondref) {
 211         print TEMP $_;
 212     }
 213     close(TEMP);
 214     my @out = `diff -u $file2 $file1 2>/dev/null`;
 215
 216     if(!$out[0]) {
 217         @out = `diff -c $file2 $file1 2>/dev/null`;
 218     }
 219
 220     return @out;
 221 }
 222
 223
 224 1;