use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil qw(t_cmp t_debug t_write_perl_script);
use Apache::TestConfig;
use Apache::TestRequest qw(GET_BODY UPLOAD_BODY
GET_BODY_ASSERT POST_BODY GET_RC GET_HEAD);
use constant WIN32 => Apache::TestConfig::WIN32;
use Cwd;
require File::Basename;
my @key_len = (5, 100, 305);
my @key_num = (5, 15, 26);
my @keys = ('a'..'z');
my $cwd = getcwd();
my %types = (perl => 'application/octet-stream');
my $vars = Apache::Test::vars;
my $perlpod = $vars->{perlpod};
if (-d $perlpod) {
opendir(my $dh, $perlpod);
my @files = grep { /\.(pod|pm)$/ } readdir $dh;
closedir $dh;
if (scalar @files > 0) {
my $file = $files[0];
$types{$file} = ($file =~ /\.pod$/) ? 'text/x-pod' : 'text/plain';
}
}
my @names = sort keys %types;
my @methods = sort qw/slurp fh tempname link io/;
my $cgi = File::Spec->catfile(Apache::Test::vars('serverroot'),
qw(cgi-bin test_cgi.pl));
t_write_perl_script($cgi, <DATA>);
#########################################################
# uncomment the following to test larger keys
my @big_key_len = (100, 500, 5000, 10000);
# if the above is uncommented, comment out the following
#my @big_key_len = (100, 500, 1000, 2500);
#########################################################
my @big_key_num = (5, 15, 25);
my @big_keys = ('a'..'z');
plan tests => 10 + @key_len * @key_num + @big_key_len * @big_key_num +
4 * @names * @methods, need_lwp && need_cgi;
require HTTP::Cookies;
my $location = '/cgi-bin';
my $script = $location . '/test_cgi.pl';
my $line_end = WIN32 ? "\r\n" : "\n";
my $filler = "0123456789" x 6400; # < 64K
# GET
for my $key_len (@key_len) {
for my $key_num (@key_num) {
my @query = ();
my $len = 0;
for my $key (@keys[0..($key_num-1)]) {
my $pair = "$key=" . 'd' x $key_len;
$len += length($pair) - 1;
push @query, $pair;
}
my $query = join ";", @query;
t_debug "# of keys : $key_num, key_len $key_len";
my $body = GET_BODY "$script?$query";
ok t_cmp($body,
$len,
"GET long query");
}
}
# POST
for my $big_key_len (@big_key_len) {
for my $big_key_num (@big_key_num) {
my @query = ();
my $len = 0;
for my $big_key (@big_keys[0..($big_key_num-1)]) {
my $pair = "$big_key=" . 'd' x $big_key_len;
$len += length($pair) - 1;
push @query, $pair;
}
my $query = join ";", @query;
t_debug "# of keys : $big_key_num, big_key_len $big_key_len";
my $body = POST_BODY($script, content => $query);
ok t_cmp($body,
$len,
"POST big data");
}
}
ok t_cmp(POST_BODY("$script?foo=1", Content => $filler),
"\tfoo => 1$line_end", "simple post");
ok t_cmp(GET_BODY("$script?foo=%3F&bar=hello+world"),
"\tfoo => ?$line_end\tbar => hello world$line_end", "simple get");
my $body = POST_BODY($script, content =>
"aaa=$filler;foo=1;bar=2;filler=$filler");
ok t_cmp($body, "\tfoo => 1$line_end\tbar => 2$line_end",
"simple post");
$body = POST_BODY("$script?foo=1", content =>
"intro=$filler&bar=2&conclusion=$filler");
ok t_cmp($body, "\tfoo => 1$line_end\tbar => 2$line_end",
"simple post");
$body = UPLOAD_BODY("$script?foo=1", content => $filler);
ok t_cmp($body, "\tfoo => 1$line_end",
"simple upload");
{
my $test = 'netscape';
my $key = 'apache';
my $value = 'ok';
my $cookie = qq{$key=$value};
ok t_cmp(GET_BODY("$script?test=$test&key=$key", Cookie => $cookie),
$value,
$test);
}
{
my $test = 'rfc';
my $key = 'apache';
my $value = 'ok';
my $cookie = qq{\$Version="1"; $key="$value"; \$Path="$location"};
ok t_cmp(GET_BODY("$script?test=$test&key=$key", Cookie => $cookie),
qq{"$value"},
$test);
}
{
my $test = 'encoded value with space';
my $key = 'apache';
my $value = 'okie dokie';
my $cookie = "$key=" . join '',
map {/ / ? '+' : sprintf '%%%.2X', ord} split //, $value;
ok t_cmp(GET_BODY("$script?test=$test&key=$key", Cookie => $cookie),
$value,
$test);
}
{
my $test = 'bake';
my $key = 'apache';
my $value = 'ok';
my $cookie = "$key=$value";
my ($header) = GET_HEAD("$script?test=$test&key=$key",
Cookie => $cookie) =~ /^#Set-Cookie:\s+(.+)/m;
ok t_cmp($header, $cookie, $test);
}
{
my $test = 'bake2';
my $key = 'apache';
my $value = 'ok';
my $cookie = qq{\$Version="1"; $key="$value"; \$Path="$location"};
my ($header) = GET_HEAD("$script?test=$test&key=$key",
Cookie => $cookie) =~ /^#Set-Cookie2:\s+(.+)/m;
ok t_cmp($header, qq{$key="$value"; Version=1; path="$location"}, $test);
}
# file upload tests
foreach my $name (@names) {
my $url = ( ($name =~ /\.(pod|pm)$/) ?
"getfiles-perl-pod/" : "/getfiles-binary-" ) . $name;
my $content = GET_BODY_ASSERT($url);
my $path = File::Spec->catfile($cwd, 't', $name);
open my $fh, ">", $path or die "Cannot open $path: $!";
binmode $fh;
print $fh $content;
close $fh;
}
eval {require Digest::MD5;};
my $has_md5 = $@ ? 0 : 1;
foreach my $file( map {File::Spec->catfile($cwd, 't', $_)} @names) {
my $size = -s $file;
my $cs = $has_md5 ? cs($file) : 0;
my $basename = File::Basename::basename($file);
for my $method ( @methods) {
my $result = UPLOAD_BODY("$script?method=$method;has_md5=$has_md5",
filename => $file);
$result =~ s{\r}{}g;
my %h = map {$_;} split /[=&;]/, $result, -1;
ok t_cmp($h{type}, $types{$basename},
"'type' test for $method on $basename");
ok t_cmp($h{filename}, $basename,
"'filename' test for $method on $basename");
ok t_cmp($h{size}, $size,
"'size' test for $method on $basename");
ok t_cmp($h{md5}, $cs,
"'checksum' test for $method on $basename");
}
unlink $file if -f $file;
}
sub cs {
my $file = shift;
open my $fh, '<', $file or die qq{Cannot open "$file": $!};
binmode $fh;
my $md5 = Digest::MD5->new->addfile($fh)->hexdigest;
close $fh;
return $md5;
}
__DATA__
use strict;
use File::Basename;
use warnings FATAL => 'all';
use blib;
use APR;
use APR::Pool;
use APR::Request::Param;
use APR::Request::Cookie;
use APR::Request::CGI;
use File::Spec;
require File::Basename;
my $p = APR::Pool->new();
apreq_log("Creating APR::Request::CGI object");
my $req = APR::Request::CGI->handle($p);
my $foo = $req->param("foo");
my $bar = $req->param("bar");
my $test = $req->param("test");
my $key = $req->param("key");
my $method = $req->param("method");
if ($foo || $bar) {
print "Content-Type: text/plain\n\n";
if ($foo) {
apreq_log("foo => $foo");
print "\tfoo => $foo\n";
}
if ($bar) {
apreq_log("bar => $bar");
print "\tbar => $bar\n";
}
}
elsif ($test && $key) {
my $jar = $req->jar;
$jar->cookie_class("APR::Request::Cookie");
my %cookies = %$jar;
apreq_log("Fetching cookie $key");
if ($cookies{$key}) {
if ($test eq "bake") {
printf "Set-Cookie: %s\n", $cookies{$key}->as_string;
}
elsif ($test eq "bake2") {
printf "Set-Cookie2: %s\n", $cookies{$key}->as_string;
}
print "Content-Type: text/plain\n\n";
print APR::Request::decode($cookies{$key}->value);
}
}
elsif ($method) {
my $temp_dir = File::Spec->tmpdir;
my $has_md5 = $req->args('has_md5');
require Digest::MD5 if $has_md5;
my $body = $req->body;
$body->param_class("APR::Request::Param");
my ($param) = values %{$body->uploads($p)};
my $type = $param->upload_type;
my $basename = File::Basename::basename($param->upload_filename);
my ($data, $fh);
if ($method eq 'slurp') {
$param->upload_slurp($data);
}
elsif ($method eq 'fh') {
read $param->upload_fh, $data, $param->upload_size;
}
elsif ($method eq 'tempname') {
my $name = $param->upload_tempname;
open $fh, "<", $name or die "Can't open $name: $!";
binmode $fh;
read $fh, $data, $param->upload_size;
close $fh;
}
elsif ($method eq 'link') {
my $link_file = File::Spec->catfile($temp_dir, "linkfile");
unlink $link_file if -f $link_file;
$param->upload_link($link_file) or die "Can't link to $link_file: $!";
open $fh, "<", $link_file or die "Can't open $link_file: $!";
binmode $fh;
read $fh, $data, $param->upload_size;
close $fh;
unlink $link_file if -f $link_file;
}
elsif ($method eq 'io') {
read $param->upload_io, $data, $param->upload_size;
}
else {
die "unknown method: $method";
}
my $temp_file = File::Spec->catfile($temp_dir, $basename);
unlink $temp_file if -f $temp_file;
open my $wfh, ">", $temp_file or die "Can't open $temp_file: $!";
binmode $wfh;
print $wfh $data;
close $wfh;
my $cs = $has_md5 ? cs($temp_file) : 0;
my $size = -s $temp_file;
my $result = qq{type=$type;size=$size;filename=$basename;md5=$cs};
print "Content-Type: text/plain\n\n$result";
unlink $temp_file if -f $temp_file;
}
else {
my $len = 0;
print "Content-Type: text/plain\n\n";
apreq_log("Fetching all parameters");
for ($req->param) {
my $param = $req->param($_);
next unless $param;
my $length = length($param);
apreq_log("$_ has a value of length $length");
$len += length($_) + $length;
}
print $len;
}
sub apreq_log {
my $msg = shift;
my ($pkg, $file, $line) = caller;
$file = basename($file);
print STDERR "$file($line): $msg\n";
}
sub cs {
my $file = shift;
open my $fh, '<', $file or die qq{Cannot open "$file": $!};
binmode $fh;
my $md5 = Digest::MD5->new->addfile($fh)->hexdigest;
close $fh;
return $md5;
}