randyk 2004/07/12 06:10:14
Added: glue/perl/t/apreq upload.t
glue/perl/t/response/TestApReq upload.pm
Log:
Reviewed by: joes
add upload test for the perl glue involving uploading text and binary files.
Revision Changes Path
1.1 httpd-apreq-2/glue/perl/t/apreq/upload.t
Index: upload.t
===================================================================
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use Apache::TestRequest qw(UPLOAD_BODY GET_BODY_ASSERT);
use Cwd;
require File::Basename;
my $cwd = getcwd();
my $location = "/TestApReq__upload";
my %types = (perl => 'application/octet-stream',
httpd => 'application/octet-stream',
'perltoc.pod' => 'text/x-pod',
'perlport.pod' => 'text/x-pod');
my @names = sort keys %types;
my @methods = sort qw/slurp fh tempname link io/;
plan tests => @names * @methods, have_lwp;
foreach my $name (@names) {
my $url = ( ($name =~ /\.pod$/) ?
"getfiles-perl-pod/" : "/getfiles-binary-" ) . $name;
my $content = GET_BODY_ASSERT($url);
my $path = File::Spec->catfile($cwd, $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, $_)} @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("$location?method=$method;has_md5=$has_md5",
filename => $file);
my $expected = <<END;
type: $types{$basename}
size: $size
filename: $basename
md5: $cs
END
ok t_cmp($result, $expected, "$method test for $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;
}
1.1 httpd-apreq-2/glue/perl/t/response/TestApReq/upload.pm
Index: upload.pm
===================================================================
package TestApReq::upload;
use strict;
use warnings FATAL => 'all';
use Apache::RequestRec;
use Apache::RequestIO;
use Apache::Request ();
use Apache::Upload;
use File::Spec;
require File::Basename;
sub handler {
my $r = shift;
my $req = Apache::Request->new($r);
my $temp_dir = File::Spec->tmpdir;
my $method = $req->args('method');
my $has_md5 = $req->args('has_md5');
require Digest::MD5 if $has_md5;
my $upload = $req->upload(($req->upload)[0]);
my $type = $upload->type;
my $basename = File::Basename::basename($upload->filename);
my ($data, $fh);
if ($method eq 'slurp') {
$upload->slurp($data);
}
elsif ($method eq 'fh') {
read $upload->fh, $data, $upload->size;
}
elsif ($method eq 'tempname') {
my $name = $upload->tempname;
open $fh, "<:APR", $name, $upload->pool
or die "Can't open $name: $!";
binmode $fh;
read $fh, $data, $upload->size;
close $fh;
}
elsif ($method eq 'link') {
my $link_file = File::Spec->catfile($temp_dir, "linkfile");
unlink $link_file if -f $link_file;
$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, $upload->size;
close $fh;
unlink $link_file if -f $link_file;
}
elsif ($method eq 'io') {
read $upload->io, $data, $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;
$req->content_type('text/plain');
my $size = -s $temp_file;
$r->print(<<END);
type: $type
size: $size
filename: $basename
md5: $cs
END
unlink $temp_file if -f $temp_file;
return 0;
}
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;
}
1;
__END__
