mirror of
https://github.com/moparisthebest/curl
synced 2024-11-15 14:05:03 -05:00
343 lines
8.1 KiB
Perl
343 lines
8.1 KiB
Perl
#***************************************************************************
|
|
# _ _ ____ _
|
|
# Project ___| | | | _ \| |
|
|
# / __| | | | |_) | |
|
|
# | (__| |_| | _ <| |___
|
|
# \___|\___/|_| \_\_____|
|
|
#
|
|
# Copyright (C) 1998 - 2021, Daniel Stenberg, <daniel@haxx.se>, et al.
|
|
#
|
|
# This software is licensed as described in the file COPYING, which
|
|
# you should have received as part of this distribution. The terms
|
|
# are also available at https://curl.se/docs/copyright.html.
|
|
#
|
|
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
|
|
# copies of the Software, and permit persons to whom the Software is
|
|
# furnished to do so, under the terms of the COPYING file.
|
|
#
|
|
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
|
|
# KIND, either express or implied.
|
|
#
|
|
###########################################################################
|
|
|
|
#use strict;
|
|
|
|
my @xml;
|
|
my $xmlfile;
|
|
|
|
my $warning=0;
|
|
my $trace=0;
|
|
|
|
use MIME::Base64;
|
|
|
|
sub decode_hex {
|
|
my $s = $_;
|
|
# remove everything not hex
|
|
$s =~ s/[^A-Fa-f0-9]//g;
|
|
# encode everything
|
|
$s =~ s/([a-fA-F0-9][a-fA-F0-9])/chr(hex($1))/eg;
|
|
return $s;
|
|
}
|
|
|
|
sub getpartattr {
|
|
# if $part is undefined (ie only one argument) then
|
|
# return the attributes of the section
|
|
|
|
my ($section, $part)=@_;
|
|
|
|
my %hash;
|
|
my $inside=0;
|
|
|
|
# print "Section: $section, part: $part\n";
|
|
|
|
for(@xml) {
|
|
# print "$inside: $_";
|
|
if(!$inside && ($_ =~ /^ *\<$section/)) {
|
|
$inside++;
|
|
}
|
|
if((1 ==$inside) && ( ($_ =~ /^ *\<$part([^>]*)/) ||
|
|
!(defined($part)) )
|
|
) {
|
|
$inside++;
|
|
my $attr=$1;
|
|
|
|
while($attr =~ s/ *([^=]*)= *(\"([^\"]*)\"|([^\> ]*))//) {
|
|
my ($var, $cont)=($1, $2);
|
|
$cont =~ s/^\"(.*)\"$/$1/;
|
|
$hash{$var}=$cont;
|
|
}
|
|
last;
|
|
}
|
|
# detect end of section when part wasn't found
|
|
elsif((1 ==$inside) && ($_ =~ /^ *\<\/$section\>/)) {
|
|
last;
|
|
}
|
|
elsif((2 ==$inside) && ($_ =~ /^ *\<\/$part/)) {
|
|
$inside--;
|
|
}
|
|
}
|
|
return %hash;
|
|
}
|
|
|
|
sub getpart {
|
|
my ($section, $part)=@_;
|
|
|
|
my @this;
|
|
my $inside=0;
|
|
my $base64=0;
|
|
my $hex=0;
|
|
my $line;
|
|
|
|
for(@xml) {
|
|
$line++;
|
|
if(!$inside && ($_ =~ /^ *\<$section/)) {
|
|
$inside++;
|
|
}
|
|
elsif(($inside >= 1) && ($_ =~ /^ *\<$part[ \>]/)) {
|
|
if($inside > 1) {
|
|
push @this, $_;
|
|
}
|
|
elsif($_ =~ /$part [^>]*base64=/) {
|
|
# attempt to detect our base64 encoded part
|
|
$base64=1;
|
|
}
|
|
elsif($_ =~ /$part [^>]*hex=/) {
|
|
# attempt to detect a hex-encoded part
|
|
$hex=1;
|
|
}
|
|
$inside++;
|
|
}
|
|
elsif(($inside >= 2) && ($_ =~ /^ *\<\/$part[ \>]/)) {
|
|
if($inside > 2) {
|
|
push @this, $_;
|
|
}
|
|
$inside--;
|
|
}
|
|
elsif(($inside >= 1) && ($_ =~ /^ *\<\/$section/)) {
|
|
if($inside > 1) {
|
|
print STDERR "$xmlfile:$line:1: error: missing </$part> tag before </$section>\n";
|
|
@this = ("format error in $xmlfile");
|
|
}
|
|
if($trace && @this) {
|
|
print STDERR "*** getpart.pm: $section/$part returned data!\n";
|
|
}
|
|
if($warning && !@this) {
|
|
print STDERR "*** getpart.pm: $section/$part returned empty!\n";
|
|
}
|
|
if($base64) {
|
|
# decode the whole array before returning it!
|
|
for(@this) {
|
|
my $decoded = decode_base64($_);
|
|
$_ = $decoded;
|
|
}
|
|
}
|
|
elsif($hex) {
|
|
# decode the whole array before returning it!
|
|
for(@this) {
|
|
my $decoded = decode_hex($_);
|
|
$_ = $decoded;
|
|
}
|
|
}
|
|
return @this;
|
|
}
|
|
elsif($inside >= 2) {
|
|
push @this, $_;
|
|
}
|
|
}
|
|
if($trace && @this) {
|
|
# section/part has data but end of section not detected,
|
|
# end of file implies end of section.
|
|
print STDERR "*** getpart.pm: $section/$part returned data!\n";
|
|
}
|
|
if($warning && !@this) {
|
|
# section/part does not exist or has no data without an end of
|
|
# section; end of file implies end of section.
|
|
print STDERR "*** getpart.pm: $section/$part returned empty!\n";
|
|
}
|
|
return @this;
|
|
}
|
|
|
|
sub partexists {
|
|
my ($section, $part)=@_;
|
|
|
|
my $inside = 0;
|
|
|
|
for(@xml) {
|
|
if(!$inside && ($_ =~ /^ *\<$section/)) {
|
|
$inside++;
|
|
}
|
|
elsif((1 == $inside) && ($_ =~ /^ *\<$part[ \>]/)) {
|
|
return 1; # exists
|
|
}
|
|
elsif((1 == $inside) && ($_ =~ /^ *\<\/$section/)) {
|
|
return 0; # does not exist
|
|
}
|
|
}
|
|
return 0; # does not exist
|
|
}
|
|
|
|
# Return entire document as list of lines
|
|
sub getall {
|
|
return @xml;
|
|
}
|
|
|
|
sub loadtest {
|
|
my ($file)=@_;
|
|
|
|
undef @xml;
|
|
$xmlfile = $file;
|
|
|
|
if(open(XML, "<$file")) {
|
|
binmode XML; # for crapage systems, use binary
|
|
while(<XML>) {
|
|
push @xml, $_;
|
|
}
|
|
close(XML);
|
|
}
|
|
else {
|
|
# failure
|
|
if($warning) {
|
|
print STDERR "file $file wouldn't open!\n";
|
|
}
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub fulltest {
|
|
return @xml;
|
|
}
|
|
|
|
# write the test to the given file
|
|
sub savetest {
|
|
my ($file)=@_;
|
|
|
|
if(open(XML, ">$file")) {
|
|
binmode XML; # for crapage systems, use binary
|
|
for(@xml) {
|
|
print XML $_;
|
|
}
|
|
close(XML);
|
|
}
|
|
else {
|
|
# failure
|
|
if($warning) {
|
|
print STDERR "file $file wouldn't open!\n";
|
|
}
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
#
|
|
# Strip off all lines that match the specified pattern and return
|
|
# the new array.
|
|
#
|
|
|
|
sub striparray {
|
|
my ($pattern, $arrayref) = @_;
|
|
|
|
my @array;
|
|
|
|
for(@$arrayref) {
|
|
if($_ !~ /$pattern/) {
|
|
push @array, $_;
|
|
}
|
|
}
|
|
return @array;
|
|
}
|
|
|
|
#
|
|
# pass array *REFERENCES* !
|
|
#
|
|
sub compareparts {
|
|
my ($firstref, $secondref)=@_;
|
|
|
|
my $first = join("", @$firstref);
|
|
my $second = join("", @$secondref);
|
|
|
|
# we cannot compare arrays index per index since with the base64 chunks,
|
|
# they may not be "evenly" distributed
|
|
|
|
# NOTE: this no longer strips off carriage returns from the arrays. Is that
|
|
# really necessary? It ruins the testing of newlines. I believe it was once
|
|
# added to enable tests on win32.
|
|
|
|
if($first ne $second) {
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
#
|
|
# Write a given array to the specified file
|
|
#
|
|
sub writearray {
|
|
my ($filename, $arrayref)=@_;
|
|
|
|
open(TEMP, ">$filename");
|
|
binmode(TEMP,":raw"); # cygwin fix by Kevin Roth
|
|
for(@$arrayref) {
|
|
print TEMP $_;
|
|
}
|
|
close(TEMP);
|
|
}
|
|
|
|
#
|
|
# Load a specified file and return it as an array
|
|
#
|
|
sub loadarray {
|
|
my ($filename)=@_;
|
|
my @array;
|
|
|
|
open(TEMP, "<$filename");
|
|
while(<TEMP>) {
|
|
push @array, $_;
|
|
}
|
|
close(TEMP);
|
|
return @array;
|
|
}
|
|
|
|
# Given two array references, this function will store them in two temporary
|
|
# files, run 'diff' on them, store the result and return the diff output!
|
|
|
|
sub showdiff {
|
|
my ($logdir, $firstref, $secondref)=@_;
|
|
|
|
my $file1="$logdir/check-generated";
|
|
my $file2="$logdir/check-expected";
|
|
|
|
open(TEMP, ">$file1");
|
|
for(@$firstref) {
|
|
my $l = $_;
|
|
$l =~ s/\r/[CR]/g;
|
|
$l =~ s/\n/[LF]/g;
|
|
$l =~ s/([^\x20-\x7f])/sprintf "%%%02x", ord $1/eg;
|
|
print TEMP $l;
|
|
print TEMP "\n";
|
|
}
|
|
close(TEMP);
|
|
|
|
open(TEMP, ">$file2");
|
|
for(@$secondref) {
|
|
my $l = $_;
|
|
$l =~ s/\r/[CR]/g;
|
|
$l =~ s/\n/[LF]/g;
|
|
$l =~ s/([^\x20-\x7f])/sprintf "%%%02x", ord $1/eg;
|
|
print TEMP $l;
|
|
print TEMP "\n";
|
|
}
|
|
close(TEMP);
|
|
my @out = `diff -u $file2 $file1 2>/dev/null`;
|
|
|
|
if(!$out[0]) {
|
|
@out = `diff -c $file2 $file1 2>/dev/null`;
|
|
}
|
|
|
|
return @out;
|
|
}
|
|
|
|
|
|
1;
|