CGI::Upload - CGI class for handling browser file uploads

[rob_au]

Category:

CGI Programming

Description:

This module has been written to provide a simple and secure manner by which to handle files uploaded in multipart/form-data requests through a web browser.

The following methods are exported upon request:

new($cgi)

This method creates a new CGI::Upload object. The only mandatory argument is a CGI.pm object - This is because only a single CGI.pm object can be initiated within a CGI script.

 

file_handle('field_name')

Returns the file handle to the uploaded file.

 

file_name('field_name')

Returns the filename of the uploaded file as supplied by the client web browser - This filename does not reflect the local temporary filename of the uploaded file.

 

file_type('field_name')

Returns the file type of the uploaded file as indicated by the file extension - This does not necessarily reflect the nature of the file uploaded, but allows CGI scripts to perform cursory validation on the file uploaded.

 

mime_magic('/path/to/mime.types')

This method sets and/or returns the external magic mime types file to be used for identification of files via the mime_type method. By default, identification is based upon internal mime types defined within the File::MMagic module.

 

mime_type('field_name')

Returns the file type of the uploaded file as indicated by the file magic numbers. This is the best means by which to validate the nature of the uploaded file.

 

Code updated to include Exporter - Thanks gellyfish++

package CGI::Upload;

use Carp;
use Exporter;
use File::Basename;
use File::MMagic;
use IO::File;

use strict;
use vars qw/ $VERSION @ISA @EXPORT @EXPORT_OK /;

@ISA = qw/ Exporter /;

@EXPORT_OK = qw/ file_handle file_name file_type mime_magic mime_type 
+/;

$VERSION = '1.0';


sub _handle_file {
    my $self = shift;
    my ($cgi, $param) = @_;

    my $mime_magic = $self->mime_magic;
    my $magic =
        ( length $mime_magic ) ?
        File::MMagic->new( $mime_magic ) :
        File::MMagic->new;

    my @file = fileparse($cgi->param($param), '\..*');

    return undef unless $file[0];

    my $fh = IO::File->new_tmpfile;
    my $buffer;
    while (read($cgi->param($param), $buffer, 1024)) {
        $fh->write($buffer, length($buffer));
    }
    $fh->seek(0, 0);

    my $object = {
        'file_handle'   =>  $fh,
        'file_name'     =>  $file[0] . $file[2],
        'file_type'     =>  substr(lc $file[2], 1),
        'mime_type'     =>  $magic->checktype_filehandle($fh)
    };
    $fh->seek(0, 0);

    return $object;
}


sub file_handle {
    my $self = shift;
    my ($param) = @_;
    my $cgi = $self->{'_CGI'};

    return undef unless defined $cgi->param($param);

    $self->{'_PARAMS'}->{$param} = $self->_handle_file( $cgi, $param)
        unless exists $self->{'_PARAMS'}->{$param};

    return $self->{'_PARAMS'}->{$param}->{'file_handle'};
}


sub file_name {
    my $self = shift;
    my ($param) = @_;
    my $cgi = $self->{'_CGI'};

    return undef unless defined $cgi->param($param);

    $self->{'_PARAMS'}->{$param} = $self->_handle_file( $cgi, $param)
        unless exists $self->{'_PARAMS'}->{$param};

    return $self->{'_PARAMS'}->{$param}->{'file_name'};
}


sub file_type {
    my $self = shift;
    my ($param) = @_;
    my $cgi = $self->{'_CGI'};

    return undef unless defined $cgi->param($param);

    $self->{'_PARAMS'}->{$param} = $self->_handle_file( $cgi, $param)
        unless exists $self->{'_PARAMS'}->{$param};

    return $self->{'_PARAMS'}->{$param}->{'file_type'};
}


sub mime_magic {
    my $self = shift;
    my ($magic) = @_;
    if (defined $magic) {
        $self->{'_MMAGIC'} = $magic if -e $magic;
    }
    return $self->{'_MMAGIC'};
}


sub mime_type {
    my $self = shift;
    my ($param) = @_;
    my $cgi = $self->{'_CGI'};

    return undef unless defined $cgi->param($param);

    $self->{'_PARAMS'}->{$param} = $self->_handle_file( $cgi, $param)
        unless exists $self->{'_PARAMS'}->{$param};

    return $self->{'_PARAMS'}->{$param}->{'mime_type'};
}


sub new {
    my $class = shift;
    $class = ref $class if ref $class;

    my ($cgi) = @_;
    unless (( defined $cgi ) && ( $cgi->isa('CGI') )) {
        croak( "CGI::Upload->new : Single argument to method should be
+ CGI.pm object" );
    }
    my $self = bless {
        '_CGI'      =>  $cgi,
        '_MMAGIC'   =>  '',
        '_PARAMS'   =>  {}
    }, $class;
    return $self;
}


1;


__END__

[gellyfish]

Looks nice, but there is one small niggle - you have:

use vars qw/ $VERSION @ISA @EXPORT @EXPORT_OK /;

@EXPORT_OK = qw/ file_handle file_name file_type mime_magic mime_type/
+;

However you neither require Exporter nor do @ISA = qw/Exporter/ so you will have trouble if someone does:

  use CGI::Upload qw(file_name);

Update Glad to be of help, only sad I've run out of votes today :)

/J\

[miyagawa]

I've made a module with exactly the same name once in a while. CGI-Upload-0.01.tar.gz...

And I remember CGI::Upload was once registered on CPAN modules list with me the author. (But I thought my CGI::Upload implementation was not enough to publish, so had kept it hidden on the list).

You can go your way, but mine also handles MacIE's macbinary stuff automagicaly. So give it a shot before uploading it to CPAN.

--
Tatsuhiko Miyagawa
[e-mail]

[$code or die]

Looks really good. I really like the interface.

I'm curious though, CGI->upload() returns a filehandle, so does CGI->param() for that matter. I am wondering why in _handle_file() you read from this filehandle and write to a new tempfile so you can provide your own filehandle. Wouldn't it be easier to use the filehandle the CGI.pm provides?

One more thing, if you do need the new filhandle do you need to binmode() it for compatability?

___ Simon Flack ($code or die)
$,=reverse'"ro_';s,$,\$,;s,$,lc ref sub{},e;$,
=~y'_"' ';eval"die";print $_,lc substr$@,0,3;

[rob_au]

I'm curious though, CGI->upload() returns a filehandle, so does CGI->param() for that matter. I am wondering why in _handle_file() you read from this filehandle and write to a new tempfile so you can provide your own filehandle. Wouldn't it be easier to use the filehandle the CGI.pm provides?

I have actually considered this but haven't had a chance to read through the CGI.pm in detail to see exactly how it handles its temporary files. Much of this module code has evolved from subroutines that I have used in some CGI scripts in the past.

If anything, you might view the method I have taken as the defensive approach in the absence of any better informed opinion :-) This can also be seen in my resetting of the file pointer for the temporary file after calling the checktype_filehandle function from File::MMagic - While this resetting of the file pointer is in all likelihood unnecessary, I have included it for the sake of a "defensive" approach to this code.

As for the binmode on the newly-created file handle, this is a very good point - Again, I will look into this and the handling of temporary files by CGI.pm and revise this code accordingly.

Thanks again for you comments $code or die++

 

Update - I've had a look at the implementation of temporary files within CGI.pm and at this stage, I believe I will remain with the implementation I have in the code above - This is in part because of the robustness of the POSIX-based new_tmpfile method exported from IO::File which I am quite comfortable with from a "paranoia" perspective :-)

 

perl -e 's&&[e-mail]&&&split/[@.]/&&s&.com.&_&&&print'

[princepawn]

Hmmm, care to take over/update my CPAN module HTTP::File?

I have become far more a chess player than a Perl programmer thanks to this economy!

[Anonymous Monk]

Hi, would someone please be kind and post an example cgi script that uses this nice module for uploading?

[rob_au]

The following is a quick modification of an older script which I've now rewritten to use the CGI::Upload module - This little script will accept uploaded files of a specified mime type, in this example image/gif, and send them through to the email address specified.

#!/usr/bin/perl -Tw

use EMAIL   =>  '[e-mail]';
use SERVER  =>  'mail.yourdomain.com';

use CGI;
use CGI::Upload;
use Mail::Mailer;
use Net::SMTP;
use strict;

my $cgi = CGI->new;
my $upload = CGI::Upload->new( $cgi );

if ( $upload->mime_type('upload') eq 'image/gif' ) {

    my $mail = Mail::Mailer->new(
        'smtp', Server => SERVER
    );
    $mail->open({
        'To'    =>  EMAIL,
        'From'  =>  '[e-mail]'
    });

    my $buffer;
    my @results;
    my $fh = $upload->file_handle('upload');
    while (read($fh, $buffer, 45)) {
        push (@results, pack("u", $buffer));
    }
    $fh->close;

    print $mail
        join "",
        "begin 600 " . $upload->file_name('upload') . "\n",
        @results,
        "end\n\n";

    $mail->close;
}

print STDOUT $cgi->redirect( $ENV{'HTTP_REFERER'} );
exit 0;

 

perl -e 's&&[e-mail]&&&split/[@.]/&&s&.com.&_&&&print'