httpd-apreq-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From ran...@apache.org
Subject cvs commit: httpd-apreq-2/glue/perl/t/apreq cgi.t
Date Sat, 24 Jul 2004 05:18:34 GMT
randyk      2004/07/23 22:18:34

  Modified:    glue/perl/t/apreq cgi.t
  Log:
  add some file upload tests for the perl cgi test.
  
  Revision  Changes    Path
  1.7       +130 -4    httpd-apreq-2/glue/perl/t/apreq/cgi.t
  
  Index: cgi.t
  ===================================================================
  RCS file: /home/cvs/httpd-apreq-2/glue/perl/t/apreq/cgi.t,v
  retrieving revision 1.6
  retrieving revision 1.7
  diff -u -r1.6 -r1.7
  --- cgi.t	23 Jul 2004 05:54:30 -0000	1.6
  +++ cgi.t	24 Jul 2004 05:18:34 -0000	1.7
  @@ -4,14 +4,23 @@
   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 POST_BODY GET_RC GET_HEAD);
  +use Apache::TestRequest qw(GET_BODY UPLOAD_BODY 
  +                           GET_BODY_ASSERT POST_BODY GET_RC GET_HEAD);
   use constant WIN32 => Apache::TestConfig::WIN32;
   use HTTP::Cookies;
  +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',
  +             'perltoc.pod' => 'text/x-pod');
  +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));
   
  @@ -26,7 +35,8 @@
   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;
  +plan tests => 10 + @key_len * @key_num + @big_key_len * @big_key_num +
  +  @names * @methods;
   
   my $location = '/cgi-bin';
   my $script = $location . '/test_cgi.pl';
  @@ -145,17 +155,65 @@
       ok t_cmp($header, qq{$key="$value"; Version=1; path="$location"}, $test);
   }
   
  +# file upload tests
  +
  +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, '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 $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;
  +}
  +
   __DATA__
   use strict;
   use File::Basename;
   use warnings FATAL => 'all';
  +use blib;
   use Apache2;
   use APR;
   use APR::Pool;
  -use blib;
  -use Apache2;
   use Apache::Request;
   use Apache::Cookie;
  +use Apache::Upload;
  +use File::Spec;
  +require File::Basename;
   
   my $p = APR::Pool->new();
   
  @@ -167,6 +225,7 @@
   
   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";
  @@ -195,6 +254,64 @@
       }
   }
   
  +elsif ($method) {
  +    my $temp_dir = File::Spec->tmpdir;
  +    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, "<", $name 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;
  + 
  +    my $size = -s $temp_file;
  +    print <<"END";
  +
  +
  +type: $type
  +size: $size
  +filename: $basename
  +md5: $cs
  +END
  +#    unlink $temp_file if -f $temp_file;
  +}
  +
   else {
       my $len = 0;
       print "Content-Type: text/plain\n\n";
  @@ -214,4 +331,13 @@
       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;
   }
  
  
  

Mime
View raw message