mirror of
https://github.com/curl/curl.git
synced 2026-04-16 01:25:14 +08:00
7d1a5c6bdf
The base64 sections were added in a time when there was no other way to do these tests. Now we remove them again to make less "hidden" data in the test suite. For several test cases we instead then provide a sequence of binary octets which is not really better, but I have tried to minimize them. Closes #16816
380 lines
9.1 KiB
Perl
380 lines
9.1 KiB
Perl
#***************************************************************************
|
|
# _ _ ____ _
|
|
# Project ___| | | | _ \| |
|
|
# / __| | | | |_) | |
|
|
# | (__| |_| | _ <| |___
|
|
# \___|\___/|_| \_\_____|
|
|
#
|
|
# Copyright (C) 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.
|
|
#
|
|
# SPDX-License-Identifier: curl
|
|
#
|
|
###########################################################################
|
|
|
|
package getpart;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
BEGIN {
|
|
use base qw(Exporter);
|
|
|
|
our @EXPORT = qw(
|
|
compareparts
|
|
fulltest
|
|
getpart
|
|
getpartattr
|
|
loadarray
|
|
loadtest
|
|
partexists
|
|
striparray
|
|
writearray
|
|
);
|
|
}
|
|
|
|
use Memoize;
|
|
|
|
my @xml; # test data file contents
|
|
my $xmlfile; # test data file name
|
|
|
|
my $warning=0;
|
|
my $trace=0;
|
|
|
|
# Normalize the part function arguments for proper caching. This includes the
|
|
# file name in the arguments since that is an implied parameter that affects the
|
|
# return value. Any error messages will only be displayed the first time, but
|
|
# those are disabled by default anyway, so should never been seen outside
|
|
# development.
|
|
sub normalize_part {
|
|
push @_, $xmlfile;
|
|
return join("\t", @_);
|
|
}
|
|
|
|
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 testcaseattr {
|
|
my %hash;
|
|
for(@xml) {
|
|
if(($_ =~ /^ *\<testcase ([^>]*)/)) {
|
|
my $attr=$1;
|
|
while($attr =~ s/ *([^=]*)= *(\"([^\"]*)\"|([^\> ]*))//) {
|
|
my ($var, $cont)=($1, $2);
|
|
$cont =~ s/^\"(.*)\"$/$1/;
|
|
$hash{$var}=$cont;
|
|
}
|
|
}
|
|
}
|
|
return %hash;
|
|
}
|
|
|
|
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;
|
|
}
|
|
memoize('getpartattr', NORMALIZER => 'normalize_part'); # cache each result
|
|
|
|
sub getpart {
|
|
my ($section, $part)=@_;
|
|
|
|
my @this;
|
|
my $inside=0;
|
|
my $hex=0;
|
|
my $line;
|
|
|
|
for(@xml) {
|
|
$line++;
|
|
if(!$inside && ($_ =~ /^ *\<$section/)) {
|
|
$inside++;
|
|
}
|
|
elsif(($inside >= 1) && ($_ =~ /^ *\<$part[ \>]/)) {
|
|
if($inside > 1) {
|
|
push @this, $_;
|
|
}
|
|
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($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;
|
|
}
|
|
memoize('getpart', NORMALIZER => 'normalize_part'); # cache each result
|
|
|
|
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
|
|
}
|
|
# The code currently never calls this more than once per part per file, so
|
|
# caching a result that will never be used again just slows things down.
|
|
# memoize('partexists', NORMALIZER => 'normalize_part'); # cache each result
|
|
|
|
sub loadtest {
|
|
my ($file)=@_;
|
|
|
|
if(defined $xmlfile && $file eq $xmlfile) {
|
|
# This test is already loaded
|
|
return
|
|
}
|
|
|
|
undef @xml;
|
|
$xmlfile = "";
|
|
|
|
if(open(my $xmlh, "<", "$file")) {
|
|
binmode $xmlh; # for crapage systems, use binary
|
|
while(<$xmlh>) {
|
|
push @xml, $_;
|
|
}
|
|
close($xmlh);
|
|
}
|
|
else {
|
|
# failure
|
|
if($warning) {
|
|
print STDERR "file $file wouldn't open!\n";
|
|
}
|
|
return 1;
|
|
}
|
|
$xmlfile = $file;
|
|
return 0;
|
|
}
|
|
|
|
|
|
# Return entire document as list of lines
|
|
sub fulltest {
|
|
return @xml;
|
|
}
|
|
|
|
# write the test to the given file
|
|
sub savetest {
|
|
my ($file)=@_;
|
|
|
|
if(open(my $xmlh, ">", "$file")) {
|
|
binmode $xmlh; # for crapage systems, use binary
|
|
for(@xml) {
|
|
print $xmlh $_;
|
|
}
|
|
close($xmlh);
|
|
}
|
|
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)=@_;
|
|
|
|
# we cannot compare arrays index per index since with data chunks,
|
|
# they may not be "evenly" distributed
|
|
my $first = join("", @$firstref);
|
|
my $second = join("", @$secondref);
|
|
|
|
if($first =~ /%alternatives\[/) {
|
|
die "bad use of compareparts\n";
|
|
}
|
|
|
|
if($second =~ /%alternatives\[([^,]*),([^\]]*)\]/) {
|
|
# there can be many %alternatives in this chunk, so we call
|
|
# this function recursively
|
|
my $alt = $second;
|
|
$alt =~ s/%alternatives\[([^,]*),([^\]]*)\]/$1/;
|
|
|
|
# check first alternative
|
|
{
|
|
my @f;
|
|
my @s;
|
|
push @f, $first;
|
|
push @s, $alt;
|
|
if(!compareparts(\@f, \@s)) {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
$alt = $second;
|
|
$alt =~ s/%alternatives\[([^,]*),([^\]]*)\]/$2/;
|
|
# check second alternative
|
|
{
|
|
my @f;
|
|
my @s;
|
|
push @f, $first;
|
|
push @s, $alt;
|
|
if(!compareparts(\@f, \@s)) {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# neither matched
|
|
return 1;
|
|
}
|
|
|
|
if($first ne $second) {
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
#
|
|
# Write a given array to the specified file
|
|
#
|
|
sub writearray {
|
|
my ($filename, $arrayref)=@_;
|
|
|
|
open(my $temp, ">", "$filename") || die "Failure writing file";
|
|
binmode($temp,":raw"); # Cygwin fix by Kevin Roth
|
|
for(@$arrayref) {
|
|
print $temp $_;
|
|
}
|
|
close($temp) || die "Failure writing file";
|
|
}
|
|
|
|
#
|
|
# Load a specified file and return it as an array
|
|
#
|
|
sub loadarray {
|
|
my ($filename)=@_;
|
|
my @array;
|
|
|
|
if (open(my $temp, "<", "$filename")) {
|
|
while(<$temp>) {
|
|
push @array, $_;
|
|
}
|
|
close($temp);
|
|
}
|
|
return @array;
|
|
}
|
|
|
|
|
|
1;
|