package CGI::UploadEasy; use 5.006; use strict; use warnings; use CGI 2.76; use File::Spec; use Carp; $Carp::CarpLevel = 1; our $VERSION = '1.00'; # $Id: UploadEasy.pm,v 1.8 2009/02/01 21:04:22 gunnarh Exp $ =head1 NAME CGI::UploadEasy - Facilitate file uploads =head1 SYNOPSIS use CGI::UploadEasy; my $ue = CGI::UploadEasy->new(-uploaddir => '/path/to/upload/dir'); my $cgi = $ue->cgiobject; my $info = $ue->fileinfo; =head1 DESCRIPTION C<CGI::UploadEasy> is a wrapper around, and relies heavily on, L<CGI.pm|CGI>. Its purpose is to provide a simple interface to the upload functionality of C<CGI.pm>. At creation of the C<CGI::UploadEasy> object, the module saves one or more files from a file upload request in the upload directory, and information about uploaded files is made available via the B<fileinfo()> method. C<CGI::UploadEasy> performs a number of tests, which limit the risk that you encounter difficulties when developing a file upload application. =head2 Methods =cut sub new { my $class = shift; my $self = { maxsize => 1000, &_argscheck, }; $CGI::POST_MAX = $self->{maxsize} * 1024; $CGI::DISABLE_UPLOADS = 0; $CGITempFile::TMPDIRECTORY = $self->{tempdir} if $self->{tempdir}; $self->{cgi} = CGI->new; if ( my $status = $self->{cgi}->cgi_error ) { _error($self, $status, "Post too large: Maxsize $self->{maxsize} KiB exceeded."); } if ( $ENV{REQUEST_METHOD} eq 'POST' and $ENV{CONTENT_TYPE} !~ /^multipart\/form-data\b/i ) { _error($self, '400 Bad Request', 'The content-type at file uploads shall be ' . "'multipart/form-data'.<br />\nMake sure that the 'FORM' tag includes the " . 'attribute: enctype="multipart/form-data"'); } $self->{files} = _upload($self); bless $self, $class; } =over 4 =item B<my $ue = CGI::UploadEasy-E<gt>new( -uploaddir =E<gt> $dir [ , -maxsize =E<gt> $kibibytes, ... ] )> The B<new()> constructor takes hash style arguments. The following arguments are recognized: =over 4 =item B<-uploaddir> Specifying the upload directory is mandatory. =item B<-tempdir> To control which directory will be used for temporary files, set the -tempdir argument. =item B<-maxsize> Specifies the maximum size in KiB (kibibytes) of a POST request data set. Default limit is 1,000 KiB. To disable this ceiling for POST requests, set a negative -maxsize value. =back =back =cut sub cgiobject { my $self = shift; $self->{cgi}; } =over 4 =item B<$ue-E<gt>cgiobject> Returns a reference to the C<CGI> object that C<CGI::UploadEasy> uses internally, which gives access to all the L<CGI.pm|CGI> methods. If you prefer the function-oriented style, you can import a set of methods instead. Example: use CGI qw/:standard/; print header; =back =cut sub fileinfo { my $self = shift; if ( @_ ) { croak "The 'fileinfo' method does not take arguments" } $self->{files}; } =over 4 =item B<$ue-E<gt>fileinfo> Returns a reference to a 'hash of hashes' with info about uploaded files. The info may be of use for a result page and/or an email notification, and it lets you use e.g. MIME type and file size as criteria for how to further process the files. =back =cut sub otherparam { my $self = shift; if ( @_ ) { croak "The 'otherparam' method does not take arguments", "--use CGI.pm's 'param' method to access values" } my $cgi = $self->{cgi}; grep ! ref $cgi->param($_), $cgi->param; } =over 4 =item B<$ue-E<gt>otherparam> The B<otherparam()> method returns a list of parameter names besides the names of the file select controls that were used for file uploads. To access the values, use L<CGI.pm|CGI>'s B<param()> method. =back =cut sub _argscheck { my %args; my %names = ( -uploaddir => 'uploaddir', -tempdir => 'tempdir', -maxsize => 'maxsize', ); local $Carp::CarpLevel = 2; @_ % 2 == 0 and @_ > 0 or croak 'One or more name=>argument pairs are ', 'expected at the creation of the CGI::UploadEasy object'; while ( my $arg = shift ) { my $name = lc $arg; $names{$name} or croak "Unknown argument: '$arg'"; $args{ $names{$name} } = shift; } $args{uploaddir} or croak "The compulsory argument '-uploaddir' is missing"; for my $dir ( @args{ grep exists $args{$_}, qw/uploaddir tempdir/ } ) { -d $dir or croak "Can't find any directory '$dir'"; -r $dir and -w _ and -x _ or croak 'The user this script runs as ', "does not have write access to '$dir'"; } $args{maxsize} and $args{maxsize} !~ /^-?\d+$/ and croak "The '-maxsize' argument shall be an integer"; %args; } sub _upload { my $self = shift; my $cgi = $self->{cgi}; my %files; for my $TEMP ( map $cgi->upload($_), $cgi->param ) { ( my $name = $TEMP ) =~ s#.*[\]:\\/]##; $name =~ tr/ /_/ unless $^O eq 'MSWin32'; $name =~ tr/-+@a-zA-Z0-9. /_/cs; ($name) = $name =~ /^([-+@\w. ]+)$/; my $path = File::Spec->catfile( $self->{uploaddir}, $name ); # don't overwrite file with same name my $i = 2; while (1) { last unless -e $path; $name =~ s/([^.]+?)(?:_\d+)?(\.|$)/$1_$i$2/; $path = File::Spec->catfile( $self->{uploaddir}, $name ); $i++; } my ($cntrname) = $cgi->uploadInfo($TEMP)->{'Content-Disposition'} =~ /\bname="([^"]+)"/; $files{$name} = { ctrlname => $cntrname, mimetype => $cgi->uploadInfo($TEMP)->{'Content-Type'}, }; open my $OUT, '>', $path or die "Couldn't open file: $!"; if ( $files{$name}{mimetype} =~ /^text\b/ ) { binmode $TEMP, ':crlf'; print $OUT $_ while <$TEMP>; } else { binmode $OUT, ':raw'; while ( read $TEMP, my $buffer, 1024 ) { print $OUT $buffer; } } close $TEMP or die $!; # so the temporary file gets deleted close $OUT or die $!; # so file size can be grabbed below $files{$name}{bytes} = -s $path; } \%files; } sub _error { my ($self, $status, $msg) = @_; my $cgi = $self->{cgi}; print $cgi->header(-status => $status), $cgi->start_html(-title => "Error $status"), $cgi->h1('Error'), $cgi->tt($msg), $cgi->end_html; exit 1; } 1; __END__ =head1 EXAMPLE This script handles a file upload request by saving a number of files in the upload directory and printing the related info: #!/usr/bin/perl -T use strict; use warnings; use CGI::UploadEasy; use Data::Dumper; my $ue = CGI::UploadEasy->new(-uploaddir => '/path/to/upload/dir'); my $info = $ue->fileinfo; my $cgi = $ue->cgiobject; print $cgi->header('text/plain'); print Dumper $info; =head1 CAVEATS Since C<CGI::UploadEasy> is meant for file uploads, it requires that the request data is C<multipart/form-data> encoded. An C<application/x-www-form-urlencoded> POST request will cause a fatal error. No C<CGI> object may be created before the C<CGI::UploadEasy> object has been created, or else the upload will fail. Likewise, if you import method names from C<CGI.pm>, be careful not to call any C<CGI> functions before the creation of the C<CGI::UploadEasy> object. =head1 AUTHOR, COPYRIGHT AND LICENSE Copyright (c) 2005-2009 Gunnar Hjalmarsson http://www.gunnar.cc/cgi-bin/contact.pl This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<CGI.pm|CGI> =cut