view release on metacpan or  search on metacpan

lib/CGI/FileUpload.pm  view on Meta::CPAN

=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.

lib/CGI/FileUpload.pm  view on Meta::CPAN

  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:$!";
  }