CGI-FileUpload/lib/CGI/FileUpload.pm
package CGI::FileUpload;
use warnings;
use strict;
=head1 NAME
CGI::FileUpload - A module to upload file through CGI asynchrnously, know where the upload status and get back the file from a third parties on the server
=head1 VERSION
=cut
our $VERSION = '0.03';
=head1 DESCRIPTION
An uploaded file is associated with a key (corresponding to a file in a server temp directory)
When uploading is started the key is returned before the uploading completed, allowing further queries such as knowing is the upload is completed, uploaded file size etc...
=head1 SYNOPSIS
use CGI::FileUpload;
my $fupload = CGI::FileUpload->new();
...
=head1 EXPORT
=head1 FUNCTIONS
=head3 uploadDirectory()
Returns the session upload directory (by default is $CGI_FILEUPLOAD_DIR or /defaulttempdir/CGI-FileUpload)
=head3 formString([parameter=>val]);
Returns a html <FORM> string such as
<form name='cgi_fileupload' method='post' enctype='multipart/form-data'>
<input type='file' name='uploadfile'/>
<input type='hidden' name='action' value='upload'/>
<input type='hidden' name='return_format' value='text'/>
<input type='submit' value='upload'>
</form>
Parameters can be of
=over 4
=item submit_value=>string: the value displayed on the "submit button"
=item return_format=>(keyonly|text|json): the type of output at submission time (default is keyonly, but a text key=value perl line, but json should also be possible)
=item form_name=>string the form name (default is 'cgi_fileupload'
=back
=head3 idcookie(query=>$cgi_query)
Either retrieves the id cookie or build one based one random number + ip
=head1 METHODS
=head2 Constructors
=head3 my $fupload=new CGI::FileUpload();
Creates a new instance in the temp directory
=head3 my $fupload=new CGI::FileUpload(suffix=>string);
Creates a file (thus returns a key)ending with .string
=head3 my $fupload=new CGI::FileUpload(key=>string);
Read info for an existing file being (or having been) uploaded.
=head2 Getting(/setting mor internal) info
=head3 $fupload->key()
returns the reference key
=head3 $fupload->from_ipaddr()
Returns the originated IP address
=head3 $fupload->from_id()
Returns some user id (hidden in a randomized cookie)
=head3 $fupload->upload_status()
Returns a string '(uploading|completed|killed)'
=head3 $fupload->properties
Returns a Util::Properties object associated (containing status and whatever info
=head3 $fupload->file()
Returns the local file associated with the uploaded file
=head2 Actions
=head3 $fupload->upload() (query=>$cgi_query [,opts])
Start the upload. A CGI::query must be passed. Other optional arguments can be of
=over 4
=item asynchronous=>(1|0) to see if the transfer must be completed before returning (0 value). default is 1;
=back
=head3 $fupload->remove()
Removes the file upload structure from the temp directory
=head3 $fupload->kill([signal=>value])
Kill the uploading process (default signal is 'INT')
=head1 AUTHOR
Alexandre Masselot, C<< <alexandre.masselot at genebio.com> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-cgi-fileupload at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-FileUpload>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc CGI::FileUpload
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-FileUpload>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/CGI-FileUpload>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/CGI-FileUpload>
=item * Search CPAN
L<http://search.cpan.org/dist/CGI-FileUpload>
=back
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
Copyright 2007 Alexandre Masselot, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
use File::Temp qw(tempfile);
use File::Spec;
use Util::Properties;
use File::Basename;
use File::Glob qw(:glob);
use Object::InsideOut 'Exporter';
BEGIN{
our @EXPORT = qw(&uploadDirectory &idcookie);
our @EXPORT_OK = ();
}
my @key: Field(Accessor => 'key', Permission => 'public');
my @props: Field(Accessor => '_props', Permission => 'private', Type=>'Util::Properties');
my %init_args :InitArgs = (
KEY=>qr/^key$/i,
SUFFIX=>qr/^suffix$/i,
);
sub _init :Init{
my ($self, $h) = @_;
if ($h->{KEY}){ #just a set of properties
$self->key($h->{KEY});
unless (-f $self->file(".properties")){
open (FD, ">".$self->file(".properties")) or die "cannot create prop file [".$self->file(".properties")."]:$!";
close FD;
}
$self->_props(Util::Properties->new(file=>$self->file(".properties")));
}else{
my ($fh, $file);
if($h->{SUFFIX}){
($fh, $file)=tempfile(DIR=>uploadDirectory(), SUFFIX=>".$h->{SUFFIX}", UNLINK=>0);
}else{
($fh, $file)=tempfile(DIR=>uploadDirectory(), UNLINK=>0);
}
my $key=basename($file);
$self->key($key);
my $fprop=$self->file(".properties");
open(FD, ">$fprop") or die "cannot open [$fprop]: $!";
close FD;
close $fh;
my $prop=Util::Properties->new();
$prop->file_isghost(1);
$prop->file_name($self->file().".properties");
$prop->prop_set('key', $key);
$self->_props($prop);
}
};
sub _automethod :Automethod{
my ($self, $val) = @_;
my $set=exists $_[1];
my $subname=$_;
if($subname=~/^(upload_status|pid|file_orig|size|from_ipaddr|from_id)$/){
if($set){
return sub{
Carp::confess unless $self->_props;
$self->_props->prop_set($subname, $val);
}
}else{
return sub{
return $self->_props->prop_get($subname);
}
}
}
}
sub formString{
my $self=shift;
my %params=@_;
$params{submit_value}||='upload';
$params{return_format}||='keyonly';
$params{form_name}||='cgi_fileupload';
# TODO add support for oncompletion callback
return <<EOT;
<script language='javascript'>
function activateKeySuff(me, other){
other.disabled=(me.value != '');
}
</script>
<form name='$params{form_name}' method='post' enctype='multipart/form-data'>
<table border='0'>
<tr>
<td>
<input type='file' name='uploadfile'/>
</td>
</tr>
<tr>
<td>
suffix=<input type='text' name='suffix' size='5' onchange='activateKeySuff(this, this.form.key)'/> or key=<input type='text' name='key' ' onchange='activateKeySuff(this, this.form.suffix)'/>
</td>
</tr>
<tr>
<td>
<input type='submit' value='$params{submit_value}'>
</td>
</tr>
<input type='hidden' name='return_format' value='$params{return_format}'/>
<input type='hidden' name='action' value='upload'/>
</table>
</form>
EOT
}
sub upload{
my $self=shift;
my %params=@_;
my $query=$params{query} or Carp::confess("no query was passed");
my $asynchronous=(exists $params{asynchronous})?$params{asynchronous}:1;
my $filename=$query->param('uploadfile');
$self->file_orig($filename);
$self->pid($$);
$self->from_ipaddr($ENV{REMOTE_ADDR});
#upload
my $localfile=$self->file();
open (FHOUT, ">$localfile.part") or die "cannot open for writing [$$localfile.part]: $!";
my $ret;
my $retformat=$query->param('return_format') || 'keyonly';
if($retformat eq 'keyonly'){
$ret=$self->key();
}elsif($retformat eq 'text'){
$ret="key=".$self->key()."\n";
}elsif($retformat eq 'json'){
$ret='not yet...';
}else{
$query->header(-type=>'text/plain');
die "unknown return_format [$retformat]";
}
my $id=idcookie(query=>$query);
my $cookie=CGI::cookie(-name=>'cgi-fileupload-id',
-value=>$id,
-expires=>'+100d'
);
$self->from_id($id->{id});
print $query->header(-type=>'text/plain',
-cookie=>$cookie,
-length=>(length($ret))+ $asynchronous?0:1,
);
print $ret;
$self->upload_status('loading');
my $fhin=CGI::upload('uploadfile')||CORE::die "cannot convert [$filename] into filehandle: $!";
my $l=0;
while(<$fhin>){
$l+=length($_);
print FHOUT $_;
}
close FHOUT;
rename("$localfile.part", "$localfile") or die "cannot rename ($localfile.part, $localfile); $!";
$self->size(-s $localfile);
$self->upload_status('completed');
$self->pid("");
}
sub file{
my $self=shift;
my $suffix=shift;
my $ret=uploadDirectory()."/".$self->key();
$ret.="$suffix" if defined $suffix;
return $ret;
}
sub remove{
my $self=shift;
my %params=@_;
$self->kill;
foreach (glob $self->file('.*')){
unlink $_ or die "cannot remove [$_]: $!";
}
}
sub idcookie{
my %params=@_;
my $query=$params{query} or Carp::confess("no query was passed");
my %idcookie=$query->cookie('cgi-fileupload-id');
unless ($idcookie{id}){
#build a random id key
$idcookie{id}=$ENV{REMOTE_ADDR}."-".(int(rand()*10**15));
}
return \%idcookie;
}
sub kill{
my $self=shift;
my %params=@_;
my $signal=$params{signal}||'INT';
if(my $pid=$self->pid){
kill $signal,$pid;
}
}
sub uploadDirectory{
my $dir=$ENV{CGI_FILEUPLOAD_DIR} || File::Spec->tmpdir()."/CGI-FileUpload";
unless (-d $dir){
mkdir $dir or die "cannot mkdir $dir:$!";
}
return $dir;
}
1; # End of CGI::FileUpload