xref: /curl/tests/getpart.pm (revision f81f351b)
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
25package getpart;
26
27use strict;
28use warnings;
29
30BEGIN {
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
46use Memoize;
47use MIME::Base64;
48
49my @xml;      # test data file contents
50my $xmlfile;  # test data file name
51
52my $warning=0;
53my $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.
60sub normalize_part {
61    push @_, $xmlfile;
62    return join("\t", @_);
63}
64
65sub 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
74sub 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
89sub 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}
128memoize('getpartattr', NORMALIZER => 'normalize_part');  # cache each result
129
130sub 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}
207memoize('getpart', NORMALIZER => 'normalize_part');  # cache each result
208
209sub 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
231sub 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
262sub fulltest {
263    return @xml;
264}
265
266# write the test to the given file
267sub 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
292sub 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#
308sub 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 Windows.
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#
331sub 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#
345sub 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
3591;
360