httpd-apreq-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From Randy Kobes <ra...@theoryx5.uwinnipeg.ca>
Subject Re: [apreq-2] perl glue upload tests
Date Sun, 11 Jul 2004 16:10:00 GMT
On Sat, 10 Jul 2004, Joe Schaefer wrote:

> Randy Kobes <randy@theoryx5.uwinnipeg.ca> writes:
>
> > In order to try to keep tabs on the Win32 line-endings
> > issues, especially with uploads, I wrote some additional
> > upload tests for the perl glue. They do duplicate some of
> > the upload tests in request.pm; however, they use files,
> > including a binary file (image).
>
> +1 to commit it - I've been meaning to do this soon,
> but you beat me to it :-).
>
> > Anyway, for what it's worth, here they are: this assumes the
> > apache_pb2.png under $APACHE2/icons/ has been copied into
> > glue/perl/t/apreq/.
>
> OK- is there a way to tell the test suite to prefetch the image
> from some standard location instead of having to add the image
> to cvs?

That's a good idea - Apache-Test actually provides in the
generated httpd.conf the locations of the perl and httpd
binaries, as well as the directory to the perl pod files.
Those we could use, as in the following:
==========================================================
Index: glue/perl/t/apreq/upload.t
===================================================================
RCS file: glue/perl/t/apreq/upload.t
diff -N glue/perl/t/apreq/upload.t
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ glue/perl/t/apreq/upload.t	11 Jul 2004 15:54:39 -0000
@@ -0,0 +1,63 @@
+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;
+}
Index: glue/perl/t/response/TestApreq/upload.pm
===================================================================
RCS file: glue/perl/t/response/TestApreq/upload.pm
diff -N glue/perl/t/response/TestApreq/upload.pm
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ glue/perl/t/response/TestApreq/upload.pm	11 Jul 2004 15:54:39 -0000
@@ -0,0 +1,88 @@
+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__

==============================================================

In this version, I used a comparison of the checksums
between the original and uploaded files, rather than the
content itself, as that was easier on the eyes when running
the tests in verbose mode.

A note on the 'link' method in upload.pm - here I took the
link file, and then made a copy to extract the data. The
reason for the extra copy is that, on Win32, the file size
of the link file is reported as zero, I think because at
that point the associated file handle is still open.

-- 
best regards,
randy

Mime
View raw message