PERL Modules - CGI::UploadEasy - request for comments

Author

CGI::UploadEasy - request for comments

Gunnar Hjalmarsson

2005-04-07, 3:56 am

Hi all,

Judging from questions to these groups and other similar forums, one
area where beginners often encounter difficulties is file uploads. The
just uploaded CPAN module CGI::UploadEasy is an attempt to help prevent
possible hazzle with upload scripts.

<Quoted from README>
CGI::UploadEasy is a wrapper around, and relies heavily on, CGI.pm.
Its purpose is to provide a simple interface to the upload
functionality of CGI.pm.

At creation of the 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 fileinfo()
method. CGI::UploadEasy performs a number of tests, which limit the
risk that you encounter difficulties when developing a file upload
application.
</Quoted from README>

Actually, with CGI::UploadEasy, Perl code for handling file uploads is
as easy to write as the code for ordinary CGI parsing using CGI.pm. :)

Any kind of comments on the module would be much appreciated.

CGI::UploadEasy is available at CPAN:
http://search.cpan.org/CPAN/authors...asy-0.10.tar.gz
(but not yet via "perl -MCPAN -e shell") and to make it easy to acquaint
oneself with it, I wrote this script:
http://www.gunnar.cc/programs/upload.pl.txt

The whole UploadEasy.pm file follows below. ( Yes, I know, 300
additional lines, but it's with the aim of facilitating comments on
details in the code or POD... ;-) )

Thanks in advance!

++++++++++++++++++++++++++++++++++++++++
+++++++++++++

package CGI::UploadEasy;

use 5.006;
use strict;
use warnings;
use CGI 2.76;
use File::Spec;

our $VERSION = '0.10';
# $Id: UploadEasy.pm,v 1.1.1.1 2005/03/31 15:21:01 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. -maxsize is 1,000 KiB by default. To disable this ceiling for POST
requests, give -maxsize a negative 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;
my ($file, $line) = (caller)[1,2];
if ( @_ ) { die "The 'fileinfo' method does not take arguments ",
"at $file line $line.\n" }
$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;
my ($file, $line) = (caller)[1,2];
if ( @_ ) { die "The 'otherparam' method does not take ",
"arguments--use CGI.pm's 'param' method to access values at ",
"$file line $line.\n" }
my $cgi = $self->{cgi};
grep { ! ref $cgi->param($_) and $cgi->param($_) } $cgi->param;
}

=over 4

=item B<$ue-E<gt>otherparam>

The B<otherparam()> method returns a list of parameter names
representing POSTed data besides uploaded files. To access the values,
use L<CGI.pm's|CGI> B<param()> method.

=back

=cut

sub _argscheck {
my $ref = shift;
my %args;
my %names = (
-uploaddir => 'uploaddir',
-tempdir => 'tempdir',
-maxsize => 'maxsize',
);
my $context = sprintf 'at %s line %s', (caller 1)[1,2];

@$ref % 2 == 0 and @$ref > 0 or die 'One or more name=>argument '
. 'pairs are expected at the creation of the CGI::UploadEasy '
. "object $context.\n";

while ( local $_ = shift @$ref ) {
my $name = lc;
$names{$name} or die "Unknown argument: '$_' $context.\n";
$args{ $names{$name} } = shift @$ref;
}
$args{uploaddir} or die "The compulsory argument '-uploaddir' is "
. "missing $context.\n";

for my $dir ( @args{ grep exists $args{$_},
qw/uploaddir tempdir/ } ) {
-d $dir or die "Can't find any directory '$dir' $context.\n";
-r $dir and -w _ and -x _ or die 'The user this script runs as '
. "does not have write access to '$dir' $context.\n";
}
$args{maxsize} and $args{maxsize} !~ /^-?\d+$/ and
die "The '-maxsize' argument shall be an integer $context.\n";

%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 © 2005 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

--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl

--
PLEASE NOTE: comp.infosystems.www.authoring.cgi is a
SELF-MODERATED newsgroup. aa.net and boutell.com are
NOT the originators of the articles and are NOT responsible
for their content.

HOW TO POST to comp.infosystems.www.authoring.cgi:
http://www.thinkspot.net/ciwac/howtopost.html

Gunnar Hjalmarsson

2005-04-08, 3:56 am

At March 31 Gunnar Hjalmarsson wrote:
>
> CGI::UploadEasy is an attempt to help prevent possible hazzle with
> upload scripts.
>
> CGI::UploadEasy is a wrapper around, and relies heavily on, CGI.pm.
> Its purpose is to provide a simple interface to the upload
> functionality of CGI.pm.

I found a bug, so a new version (0.11) has been uploaded to CPAN.

> Any kind of comments on the module would be much appreciated.
> ...
> to make it easy to acquaint oneself with it, I wrote this script:
> http://www.gunnar.cc/programs/upload.pl.txt

After the bug fix, and if nobody tells me otherwise, I take it that I
wrote TPPM (The Perfect Perl Module). ;-)

--
Gunnar Hjalmarsson
Email: http://www.gunnar.cc/cgi-bin/contact.pl

--
PLEASE NOTE: comp.infosystems.www.authoring.cgi is a
SELF-MODERATED newsgroup. aa.net and boutell.com are
NOT the originators of the articles and are NOT responsible
for their content.

HOW TO POST to comp.infosystems.www.authoring.cgi:
http://www.thinkspot.net/ciwac/howtopost.html

Sponsored Links