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

    use CGI::FileUpload;

    my $fupload = CGI::FileUpload->new();
    ...

    perldoc CGI::FileUpload

package CGI::FileUpload;

use warnings;
use strict;

our $VERSION = '0.03';

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