package Catalyst::Request::Upload;
use Moose;
with 'MooseX::Emulate::Class::Accessor::Fast';
use Catalyst::Exception;
use File::Copy ();
use IO::File ();
use File::Spec::Unix;
use namespace::clean -except => 'meta';
has filename => (is => 'rw');
has headers => (is => 'rw');
has size => (is => 'rw');
has tempname => (is => 'rw');
has type => (is => 'rw');
has basename => (is => 'ro', lazy_build => 1);
has raw_basename => (is => 'ro', lazy_build => 1);
has charset => (is=>'ro', predicate=>'has_charset');
has fh => (
is => 'rw',
required => 1,
lazy => 1,
default => sub {
my $self = shift;
my $fh = IO::File->new($self->tempname, IO::File::O_RDONLY);
unless ( defined $fh ) {
my $filename = $self->tempname;
Catalyst::Exception->throw(
message => qq/Can't open '$filename': '$!'/ );
}
return $fh;
},
);
sub _build_basename {
my $basename = shift->raw_basename;
$basename =~ s|[^\w\.-]+|_|g;
return $basename;
}
sub _build_raw_basename {
my $self = shift;
my $basename = $self->filename;
$basename =~ s|\\|/|g;
$basename = ( File::Spec::Unix->splitpath($basename) )[2];
return $basename;
}
no Moose;
=for stopwords uploadtmp
=head1 NAME
Catalyst::Request::Upload - handles file upload requests
=head1 SYNOPSIS
my $upload = $c->req->upload('field');
$upload->basename;
$upload->copy_to;
$upload->fh;
$upload->decoded_fh
$upload->filename;
$upload->headers;
$upload->link_to;
$upload->size;
$upload->slurp;
$upload->decoded_slurp;
$upload->tempname;
$upload->type;
$upload->charset;
To specify where Catalyst should put the temporary files, set the 'uploadtmp'
option in the Catalyst config. If unset, Catalyst will use the system temp dir.
__PACKAGE__->config( uploadtmp => '/path/to/tmpdir' );
See also L<Catalyst>.
=head1 DESCRIPTION
This class provides accessors and methods to handle client upload requests.
=head1 METHODS
=head2 $upload->new
Simple constructor.
=head2 $upload->copy_to
Copies the temporary file using L<File::Copy>. Returns true for success,
false for failure.
$upload->copy_to('/path/to/target');
=cut
sub copy_to {
my $self = shift;
return File::Copy::copy( $self->tempname, @_ );
}
=head2 $upload->is_utf8_encoded
Returns true of the upload defines a character set at that value is 'UTF-8'.
This does not try to inspect your upload and make any guesses if the Content
Type charset is undefined.
=cut
sub is_utf8_encoded {
my $self = shift;
if(my $charset = $self->charset) {
return $charset eq 'UTF-8' ? 1 : 0;
}
return 0;
}
=head2 $upload->fh
Opens a temporary file (see tempname below) and returns an L<IO::File> handle.
This is a filehandle that is opened with no additional IO Layers.
=head2 $upload->decoded_fh(?$encoding)
Returns a filehandle that has binmode set to UTF-8 if a UTF-8 character set
is found. This also accepts an override encoding value that you can use to
force a particular L<PerlIO> layer. If neither are found the filehandle is
set to :raw.
This is useful if you are pulling the file into code and inspecting bits and
maybe then sending those bits back as the response. (Please note this is not
a suitable filehandle to set in the body; use C<fh> if you are doing that).
Please note that using this method sets the underlying filehandle IO layer
so once you use this method if you go back and use the C<fh> method you
still get the IO layer applied.
=cut
sub decoded_fh {
my ($self, $layer) = @_;
my $fh = $self->fh;
$layer = ":encoding(UTF-8)" if !$layer && $self->is_utf8_encoded;
$layer = ':raw' unless $layer;
binmode($fh, $layer);
return $fh;
}
=head2 $upload->filename
Returns the client-supplied filename.
=head2 $upload->headers
Returns an L<HTTP::Headers> object for the request.
=head2 $upload->link_to
Creates a hard link to the temporary file. Returns true for success,
false for failure.
$upload->link_to('/path/to/target');
=cut
sub link_to {
my ( $self, $target ) = @_;
return CORE::link( $self->tempname, $target );
}
=head2 $upload->size
Returns the size of the uploaded file in bytes.
=head2 $upload->slurp(?$encoding)
Optionally accepts an argument to define an IO Layer (which is applied to
the filehandle via binmode; if no layer is defined the default is set to
":raw".
Returns a scalar containing the contents of the temporary file.
Note that this will cause the filehandle pointed to by C<< $upload->fh >> to
be reset to the start of the file using seek and the file handle to be put
into whatever encoding mode is applied.
=cut
sub slurp {
my ( $self, $layer ) = @_;
unless ($layer) {
$layer = ':raw';
}
my $content = undef;
my $handle = $self->fh;
binmode( $handle, $layer );
$handle->seek(0, IO::File::SEEK_SET);
while ( $handle->sysread( my $buffer, 8192 ) ) {
$content .= $buffer;
}
$handle->seek(0, IO::File::SEEK_SET);
return $content;
}
=head2 $upload->decoded_slurp(?$encoding)
Works just like C<slurp> except we use C<decoded_fh> instead of C<fh> to
open a filehandle to slurp. This means if your upload charset is UTF8
we binmode the filehandle to that encoding.
=cut
sub decoded_slurp {
my ( $self, $layer ) = @_;
my $handle = $self->decoded_fh($layer);
my $content = undef;
$handle->seek(0, IO::File::SEEK_SET);
while ( $handle->sysread( my $buffer, 8192 ) ) {
$content .= $buffer;
}
$handle->seek(0, IO::File::SEEK_SET);
return $content;
}
=head2 $upload->basename
Returns basename for C<filename>. This filters the name through a regexp
C<basename =~ s|[^\w\.-]+|_|g> to make it safe for filesystems that don't
like advanced characters. This will of course filter UTF8 characters.
If you need the exact basename unfiltered use C<raw_basename>.
=head2 $upload->raw_basename
Just like C<basename> but without filtering the filename for characters that
don't always write to a filesystem.
=head2 $upload->tempname
Returns the path to the temporary file.
=head2 $upload->type
Returns the client-supplied Content-Type.
=head2 $upload->charset
The character set information part of the content type, if any. Useful if you
need to figure out any encodings on the file upload.
=head2 meta
Provided by Moose
=head1 AUTHORS
Catalyst Contributors, see Catalyst.pm
=head1 COPYRIGHT
This library is free software. You can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
__PACKAGE__->meta->make_immutable;
1;