File Coverage

blib/lib/CGI/Upload.pm

Criterion	Covered	Total	%
statement	80	83	96.3
branch	21	28	75.0
condition	6	9	66.6
subroutine	13	14	92.8
pod	3	3	100.0
total	123	137	89.7

package CGI::Upload;
use strict;
use warnings;

use Carp;
use File::Basename;
use File::MMagic;
use HTTP::BrowserDetect;
use IO::File;

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

require Exporter;

@ISA = qw/ Exporter /;
@EXPORT_OK = qw/ file_handle file_name file_type mime_magic mime_type query /;

$VERSION = '1.11';


sub AUTOLOAD {
    my ( $self, $param ) = @_;

    #   Parse method name from $AUTOLOAD variable

    my $property = $AUTOLOAD;
    $property =~ s/.*:://;

    my @properties = qw/ file_handle file_name file_type mime_type /;

    unless ( grep { $property eq $_ } @properties ) {
        croak( __PACKAGE__, '->AUTOLOAD : Unsupported object method within module - ', $property );
    }

    #   Return undef if the requested parameter does not exist within
    #   CGI object

    my $cgi = $self->query;
    return unless defined $cgi->param( $param );

    #   The determination of all information about the uploaded file is
    #   performed by a private subroutine called _handle_file - This subroutine
    #   returns a hash of all information determined about the uploaded file
    #   which is be cached for subsequent requests.

    $self->{'_CACHE'}->{$param} = $self->_handle_file( $param ) unless exists $self->{'_CACHE'};

    #   Return the requested property of the uploaded file

    return $self->{'_CACHE'}->{$param}->{$property};
}


sub DESTROY {}


sub _handle_file {
    my ( $self, $param ) = @_;
    my $cgi = $self->query;

    #   Determine and set the appropriate file system parsing routines for the
    #   uploaded path name based upon the HTTP client header information.

    my $client_os = $^O;
    my $browser = HTTP::BrowserDetect->new;
    $client_os = 'MSWin32' if $browser->windows;
    $client_os = 'MacOS' if $browser->mac;
    fileparse_set_fstype($client_os);
    my @file = fileparse( $cgi->param( $param ), '\.[^.]*' );

    #   Return an undefined value if the file name cannot be parsed from the
    #   file field form parameter.

    return unless $file[0];

    #   Determine whether binary mode is required in the handling of uploaded
    #   files -
    #   Binary mode is deemed to be required when we (the server) are running one one
    #   of these platforms: for Windows, OS/2 and VMS

    my $binmode = $^O =~ /OS2|VMS|Win|DOS|Cygwin/i;

    #   Pass uploaded file into temporary file handle - This is somewhat
    #   redundant given the temporary file generation within CGI.pm, however is
    #   included to reduce dependence upon the CGI.pm module.

    my $buffer;
    my $fh = IO::File->new_tmpfile;
    binmode( $fh ) if $binmode;


    # it seems that in CGI::Simple for every call to ->upload it somehow resets
    # the file handle. or I don't really know what is the problem with this code:
    # while ( read( $cgi->upload( $param ) , $buffer, 1024 ) ) {
    my $ourfh = $cgi->upload( $param );
    while ( read( $ourfh , $buffer, 1024 ) ) {
        $fh->write( $buffer, length( $buffer ) );
    }

    #   Hold temporary file open, move file pointer to start - As the temporary
    #   file handle returned by the IO::File::new_tmpfile method is only
    #   accessible via this handle, the file handle must be held open for all
    #   operations.

    $fh->seek( 0, 0 );

    #   Retrieve the MIME magic file, if this has been defined, and construct
    #   the File::MMagic object for the identification of the MIME type of the
    #   uploaded file.

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

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

    #   Hold temporary file open, move file pointer to start - As the temporary
    #   file handle returned by the IO::File::new_tmpfile method is only
    #   accessible via this handle, the file handle must be held open for all
    #   operations.
    #
    #   The importance of this operation here is due to the MIME type
    #   identification routine of File::MMagic on the open file handle
    #   (File::MMagic->checktype_filehandle), which may or may not reset the
    #   file pointer following its operation.

    $fh->seek( 0, 0 );

    return $properties;
}


sub mime_magic {
    my ( $self, $magic ) = @_;

    #   If a filename is passed to this subroutine as an argument, this filename
    #   is taken to be the file containing file MIME types and magic numbers
    #   which File::MMagic uses for determining file MIME types.

    $self->{'_MIME'} = $magic if defined $magic;
    return $self->{'_MIME'};
}


sub new {
    my ( $class, $args ) = @_;

    if ($args and 'HASH' ne ref $args) {
        croak( __PACKAGE__, 'Argument to new should be a HASH reference');
    }
    my $query;
    my $module = "CGI";  # default module is CGI.pm if for nothing else for backword compatibility

    if ($args and $args->{query}) {
        $module = $args->{query};
    }

    if (ref $module) { # an object was passed to us
        $query = $module;
        $module = ref $module;
    } else { # assuming a name of a module was passed to us

        # load the requested module
        (my $file = $module) =~ s{::}{/}g;
        $file .= ".pm";
        require $file;


        if ("CGI::Simple" eq $module) {
            $CGI::Simple::DISABLE_UPLOADS = 0;
        }
        $query = new $module;
    }

    if ($module eq "CGI::Simple" and $CGI::Simple::VERSION < '0.075') {
        die "CGI::Simple must be at least version 0.075\n";
    }

    my $self = bless {
#        '_CACHE'    =>  {},
        '_CGI'      =>  $query,
        '_MIME'     =>  ''
    }, $class;
    return $self;
}


sub query {
    my ( $self ) = @_;
    return $self->{'_CGI'};
}


1;


__END__