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