The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/local/bin/perl -w

#################################################################
#  Emanuele Zeppieri, Mark Stosberg                             #
#  Shamelessly stolen from Data::FormValidator and CGI::Upload  #
#################################################################

use strict;
use Test::More 'no_plan';

use CGI qw/ :form /;

#-----------------------------------------------------------------------------
# %ENV setup.
#-----------------------------------------------------------------------------

my %myenv;

BEGIN {
    %myenv = (
        'SCRIPT_NAME'       => '/test.cgi',
        'SERVER_NAME'       => 'perl.org',
        'HTTP_CONNECTION'   => 'TE, close',
        'REQUEST_METHOD'    => 'POST',
        'SCRIPT_URI'        => 'http://www.perl.org/test.cgi',
        'CONTENT_LENGTH'    => 3285,
        'SCRIPT_FILENAME'   => '/home/usr/test.cgi',
        'SERVER_SOFTWARE'   => 'Apache/1.3.27 (Unix) ',
        'HTTP_TE'           => 'deflate,gzip;q=0.3',
        'QUERY_STRING'      => '',
        'REMOTE_PORT'       => '1855',
        'HTTP_USER_AGENT'   => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
        'SERVER_PORT'       => '80',
        'REMOTE_ADDR'       => '127.0.0.1',
        'CONTENT_TYPE'      => 'multipart/form-data; boundary=xYzZY',
        'SERVER_PROTOCOL'   => 'HTTP/1.1',
        'PATH'              => '/usr/local/bin:/usr/bin:/bin',
        'REQUEST_URI'       => '/test.cgi',
        'GATEWAY_INTERFACE' => 'CGI/1.1',
        'SCRIPT_URL'        => '/test.cgi',
        'SERVER_ADDR'       => '127.0.0.1',
        'DOCUMENT_ROOT'     => '/home/develop',
        'HTTP_HOST'         => 'www.perl.org'
    );

    for my $key (keys %myenv) {
        $ENV{$key} = $myenv{$key};
    }
}

END {
    for my $key (keys %myenv) {
        delete $ENV{$key};
    }
}


#-----------------------------------------------------------------------------
# Simulate the upload (really, multiple uploads contained in a single stream).
#-----------------------------------------------------------------------------

my $q;

{
    local *STDIN;
    open STDIN, '<t/upload_post_text.txt'
        or die 'missing test file t/upload_post_text.txt';
    binmode STDIN;
    $q = CGI->new;
}

{
    # That's cheating! We shouldn't do that!
    my $test = "All temp files are present";
    is( scalar(keys %{$q->{'.tmpfiles'}}), 5, $test);
}

my %uploadinfo_for = (
    'does_not_exist_gif' => {type => 'application/octet-stream', size => undef, },
    '100;100_gif'        => {type => 'image/gif',                size => 896, },
    '300x300_gif'        => {type => 'image/gif',                size => 1656, },
);


foreach my $param_name (sort keys %uploadinfo_for) {
    my $f_type = $uploadinfo_for{$param_name}->{type};
    my $f_size = $uploadinfo_for{$param_name}->{size};
    my $test = "uploadInfo: $param_name";

    my $fh = $q->upload($param_name);
    is( uploadInfo($fh)->{'Content-Type'},       $f_type,    $test);
    is( $q->uploadInfo($fh)->{'Content-Type'},   $f_type,    $test);
    is( $q->uploadInfo($fh)->{'Content-Length'}, $f_size, $test);

	# access using param
	my $param_value = $q->param($param_name);
	ok( ref( $param_value ),'param returns filehandle' );
    is( $q->uploadInfo( $param_value )->{'Content-Type'},   $f_type, $test . ' via param');
    is( $q->uploadInfo( $param_value )->{'Content-Length'}, $f_size, $test . ' via param');

	# access using Vars (is not possible)
	my $vars = $q->Vars;
	ok( ! ref( $vars->{$param_name} ),'Vars does not return filehandle' );
    ok( ! $q->uploadInfo( $vars->{$param_name} ), $test . ' via Vars');
}

my $q2 = CGI->new;

{
    my $test = "uploadInfo: works with second object instance";
    my $fh = $q2->upload('300x300_gif');
    is( $q2->uploadInfo($fh)->{'Content-Type'}, "image/gif", $test);
}