CGI-FileUpload
view release on metacpan or search on metacpan
Build.PL
Changes
MANIFEST
README
cgi/cgi-fileupload-manager.pl
cgi/cgi-upload.css
cgi/cgi-fileupload.pl
lib/CGI/FileUpload/Manager.pm
lib/CGI/FileUpload.pm
t/00-load.t
t/pod-coverage.t
t/pod.t
Makefile.PL
META.yml
---
name: CGI-FileUpload
version: 0.03
author:
- 'Alexandre Masselot <alexandre.masselot@genebio.com>'
abstract: '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'
license: perl
resources:
license: http://dev.perl.org/licenses/
requires:
CGI: 0
File::Spec: 0
File::Temp: 0
Object::InsideOut: 0
Util::Properties: 0.14
perl: 5.6.1
cgi/cgi-fileupload-manager.pl view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use Carp;
use Pod::Usage;
=head1 NAME
cgi-fileupload-manager.pl - a cgi script to display past and currently uploaded files, either for the curretn user or all (admin mode)
=cut
$|=1; # flush immediately;
BEGIN{
eval{
require DefEnv;
DefEnv::read();
};
cgi/cgi-fileupload-manager.pl view on Meta::CPAN
use CGI;
use Time::localtime;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
#warningsToBrowser(1);
my $query=new CGI;
print $query->header;
#TODO css with border in table and bit better...
my $css;
if(open (FH, "<cgi-upload.css")){
local $/;
$css=<FH>;
close FH;
}
print $query->start_html(-title => 'CGI::FileUpload manager',
-STYLE => {-verbatim => $css},
);
my $action=$query->param('action');
if (defined $action){
cgi/cgi-fileupload-manager.pl view on Meta::CPAN
}
print <<EOT;
<th><input type='submit' value='remove' name='action'/></th>
</td>
EOT
# TODO get creation time + set it coherent with sort
my $id=CGI::FileUpload::idcookie(query=>$query)->{id};
foreach(@fus){
next unless $isAdmin || ($_->from_id() eq $id);
my $status=$_->upload_status();
print " <tr>\n";
print " <td>".$_->file_orig()."</td>\n";
print " <td>".(ctime((stat($_->file('.properties')))[9]))."</td>\n";
print " <td>$status</td>\n";
print " <td>".(($status eq 'completed')?(-s $_->file()):'n/a')."</td>\n";
print " <td>".$_->from_ipaddr()."</td>\n";
print " <td>".$_->from_id()."</td>\n" if $isAdmin;
print " <td align='center'><input type='checkbox' name='key' value='".$_->key()."'/></td></tr>\n";
}
print <<EOT;
cgi/cgi-fileupload.pl view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use Carp;
use Pod::Usage;
=head1 NAME
cgi-fileupload.pl - a cgi script upload a file on the server
=cut
$|=1; # flush immediately;
BEGIN{
eval{
require DefEnv;
DefEnv::read();
cgi/cgi-fileupload.pl view on Meta::CPAN
use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
warningsToBrowser(1);
my $query=new CGI;
my $action=$query->param('action');
unless (defined $action){
print $query->header;
#TODO css with border in table and bit better...
my $css;
if(open (FH, "<cgi-upload.css")){
local $/;
$css=<FH>;
close FH;
}
print $query->start_html(-title => 'CGI::FileUpload manager',
-STYLE => {-verbatim => $css},
);
print CGI::FileUpload::formString();
print <<EOT;
visit the <a href="cgi-fileupload-manager.pl">upload manager</a>
EOT
print $query->end_html;
}else{
if($action eq 'upload'){
my %h;
$h{key}=$query->param('key') if $query->param('key');
$h{suffix}=$query->param('suffix') if $query->param('suffix');
my $fu=new CGI::FileUpload(%h);
$fu->upload(query=>$query);
}else{
die "unknonw action [$action]";
}
}
lib/CGI/FileUpload.pm view on Meta::CPAN
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.
lib/CGI/FileUpload.pm view on Meta::CPAN
=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,
);
lib/CGI/FileUpload.pm view on Meta::CPAN
$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);
lib/CGI/FileUpload.pm view on Meta::CPAN
$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
lib/CGI/FileUpload/Manager.pm view on Meta::CPAN
brwose the working directory and build a list of CGI:FileUpload
=head1 EXPORT
=head1 FUNCTIONS
=head3 lskey()
Return an array (sorted by date) of upload file keys
=head3 ls()
Return an array (sorted by date) of upload file CGI::FileUpload objects
=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.
lib/CGI/FileUpload/Manager.pm view on Meta::CPAN
require Exporter;
our (@ISA,@EXPORT,@EXPORT_OK);
@ISA=qw (Exporter);
@EXPORT=qw(&ls &lskey);
@EXPORT_OK=qw();
sub lskey{
my %tmp;
foreach(glob CGI::FileUpload::uploadDirectory()."/*.properties"){
my $k=basename($_);
$k=~s/\.properties$//;
$tmp{$k}=(stat($_))[9];
}
return sort {$tmp{$b} <=> $tmp{$a}} keys %tmp;
}
sub ls{
my @keys=lskey();
my @ret;
( run in 2.562 seconds using v1.01-cache-2.11-cpan-b16cb0d3907 )