view release on metacpan or  search on metacpan

t/cgi/upload1.t  view on Meta::CPAN

use strict;
use warnings FATAL => 'all';

use Apache::Test;
use Apache::TestUtil;
use Apache::TestRequest qw(UPLOAD_BODY GET_BODY_ASSERT);
use constant WIN32 => Apache::TestConfig::WIN32;
use Cwd;
require File::Basename;

my $cwd = getcwd();

my $module = 'TestCGI::upload1';
my $location = Apache::TestRequest::module2url($module);

my %types = (perl => 'application/octet-stream',
             httpd => '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 > 1) {
        for my $i (0 .. 1) {
            my $file = $files[$i];
            $types{$file} = ($file =~ /\.pod$/) ? 'text/x-pod' : 'text/plain';
        }
    }      
}

my @names = sort keys %types;

eval {require Digest::MD5;};
my $has_md5 = $@ ? 0 : 1;
my $filetests = $has_md5 ? 6 : 5;
plan tests => $filetests * @names, need_lwp;

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;
}

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);

    my $result = UPLOAD_BODY("$location?has_md5=$has_md5",
                               filename => $file);
    my %h = map {$_;} split /[=&;]/, $result, -1;
    ok t_cmp($h{name}, "filename", "test for name");
    ok t_cmp($h{ref}, "GLOB", "test for ref");
    ok t_cmp($h{type}, $types{$basename}, "test for type");
    ok t_cmp($h{size}, $size, "test for size");
    ok t_cmp($h{filename}, $basename, "test for filename");
    if ($has_md5) {
        ok t_cmp($h{md5}, $cs, "test for cs");
    }
    unlink $file if -f $file;
}

sub cs {
    my $file = shift;
    open my $fh, '<', $file or die qq{Cannot open "$file": $!};