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:
25: my @xml;
26: my $xmlfile;
27:
28: my $warning=0;
29: my $trace=0;
30:
31: sub 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:
38: sub 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:
47: sub 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:
87: sub 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:
165: sub 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
185: sub getall {
186: return @xml;
187: }
188:
189: sub 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:
212: sub fulltest {
213: return @xml;
214: }
215:
216: # write the test to the given file
217: sub 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:
242: sub 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: #
258: sub 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: #
281: sub 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: #
295: sub 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:
310: sub 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:
345: 1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to getpart.pm CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / curl / tests