lib/Catalyst/Request/Upload.pm

   1 package Catalyst::Request::Upload;
   2
   3 use Moose;
   4 with 'MooseX::Emulate::Class::Accessor::Fast';
   5
   6 use Catalyst::Exception;
   7 use File::Copy ();
   8 use IO::File ();
   9 use File::Spec::Unix;
  10 use namespace::clean -except => 'meta';
  11
  12 has filename => (is => 'rw');
  13 has headers => (is => 'rw');
  14 has size => (is => 'rw');
  15 has tempname => (is => 'rw');
  16 has type => (is => 'rw');
  17 has basename => (is => 'ro', lazy_build => 1);
  18 has raw_basename => (is => 'ro', lazy_build => 1);
  19 has charset => (is=>'ro', predicate=>'has_charset');
  20
  21 has fh => (
  22   is => 'rw',
  23   required => 1,
  24   lazy => 1,
  25   default => sub {
  26     my $self = shift;
  27
  28     my $fh = IO::File->new($self->tempname, IO::File::O_RDONLY);
  29     unless ( defined $fh ) {
  30       my $filename = $self->tempname;
  31       Catalyst::Exception->throw(
  32           message => qq/Can't open '$filename': '$!'/ );
  33     }
  34     return $fh;
  35   },
  36 );
  37
  38 sub _build_basename {
  39     my $basename = shift->raw_basename;
  40     $basename =~ s|[^\w\.-]+|_|g;
  41     return $basename;
  42 }
  43
  44 sub _build_raw_basename {
  45     my $self = shift;
  46     my $basename = $self->filename;
  47     $basename =~ s|\\|/|g;
  48     $basename = ( File::Spec::Unix->splitpath($basename) )[2];
  49     return $basename;
  50 }
  51
  52 no Moose;
  53
  54 =for stopwords uploadtmp
  55
  56 =head1 NAME
  57
  58 Catalyst::Request::Upload - handles file upload requests
  59
  60 =head1 SYNOPSIS
  61
  62     my $upload = $c->req->upload('field');
  63
  64     $upload->basename;
  65     $upload->copy_to;
  66     $upload->fh;
  67     $upload->decoded_fh
  68     $upload->filename;
  69     $upload->headers;
  70     $upload->link_to;
  71     $upload->size;
  72     $upload->slurp;
  73     $upload->decoded_slurp;
  74     $upload->tempname;
  75     $upload->type;
  76     $upload->charset;
  77
  78 To specify where Catalyst should put the temporary files, set the 'uploadtmp'
  79 option in the Catalyst config. If unset, Catalyst will use the system temp dir.
  80
  81     __PACKAGE__->config( uploadtmp => '/path/to/tmpdir' );
  82
  83 See also L<Catalyst>.
  84
  85 =head1 DESCRIPTION
  86
  87 This class provides accessors and methods to handle client upload requests.
  88
  89 =head1 METHODS
  90
  91 =head2 $upload->new
  92
  93 Simple constructor.
  94
  95 =head2 $upload->copy_to
  96
  97 Copies the temporary file using L<File::Copy>. Returns true for success,
  98 false for failure.
  99
 100      $upload->copy_to('/path/to/target');
 101
 102 =cut
 103
 104 sub copy_to {
 105     my $self = shift;
 106     return File::Copy::copy( $self->tempname, @_ );
 107 }
 108
 109 =head2 $upload->is_utf8_encoded
 110
 111 Returns true of the upload defines a character set at that value is 'UTF-8'.
 112 This does not try to inspect your upload and make any guesses if the Content
 113 Type charset is undefined.
 114
 115 =cut
 116
 117 sub is_utf8_encoded {
 118     my $self = shift;
 119     if(my $charset = $self->charset) {
 120       return $charset eq 'UTF-8' ? 1 : 0;
 121     }
 122     return 0;
 123 }
 124
 125 =head2 $upload->fh
 126
 127 Opens a temporary file (see tempname below) and returns an L<IO::File> handle.
 128
 129 This is a filehandle that is opened with no additional IO Layers.
 130
 131 =head2 $upload->decoded_fh(?$encoding)
 132
 133 Returns a filehandle that has binmode set to UTF-8 if a UTF-8 character set
 134 is found. This also accepts an override encoding value that you can use to
 135 force a particular L<PerlIO> layer.  If neither are found the filehandle is
 136 set to :raw.
 137
 138 This is useful if you are pulling the file into code and inspecting bits and
 139 maybe then sending those bits back as the response.  (Please note this is not
 140 a suitable filehandle to set in the body; use C<fh> if you are doing that).
 141
 142 Please note that using this method sets the underlying filehandle IO layer
 143 so once you use this method if you go back and use the C<fh> method you
 144 still get the IO layer applied.
 145
 146 =cut
 147
 148 sub decoded_fh {
 149     my ($self, $layer) = @_;
 150     my $fh  = $self->fh;
 151
 152     $layer = ":encoding(UTF-8)" if !$layer && $self->is_utf8_encoded;
 153     $layer = ':raw' unless $layer;
 154
 155     binmode($fh, $layer);
 156     return $fh;
 157 }
 158
 159 =head2 $upload->filename
 160
 161 Returns the client-supplied filename.
 162
 163 =head2 $upload->headers
 164
 165 Returns an L<HTTP::Headers> object for the request.
 166
 167 =head2 $upload->link_to
 168
 169 Creates a hard link to the temporary file. Returns true for success,
 170 false for failure.
 171
 172     $upload->link_to('/path/to/target');
 173
 174 =cut
 175
 176 sub link_to {
 177     my ( $self, $target ) = @_;
 178     return CORE::link( $self->tempname, $target );
 179 }
 180
 181 =head2 $upload->size
 182
 183 Returns the size of the uploaded file in bytes.
 184
 185 =head2 $upload->slurp(?$encoding)
 186
 187 Optionally accepts an argument to define an IO Layer (which is applied to
 188 the filehandle via binmode; if no layer is defined the default is set to
 189 ":raw".
 190
 191 Returns a scalar containing the contents of the temporary file.
 192
 193 Note that this will cause the filehandle pointed to by C<< $upload->fh >> to
 194 be reset to the start of the file using seek and the file handle to be put
 195 into whatever encoding mode is applied.
 196
 197 =cut
 198
 199 sub slurp {
 200     my ( $self, $layer ) = @_;
 201
 202     unless ($layer) {
 203         $layer = ':raw';
 204     }
 205
 206     my $content = undef;
 207     my $handle  = $self->fh;
 208
 209     binmode( $handle, $layer );
 210
 211     $handle->seek(0, IO::File::SEEK_SET);
 212     while ( $handle->sysread( my $buffer, 8192 ) ) {
 213         $content .= $buffer;
 214     }
 215
 216     $handle->seek(0, IO::File::SEEK_SET);
 217     return $content;
 218 }
 219
 220 =head2 $upload->decoded_slurp(?$encoding)
 221
 222 Works just like C<slurp> except we use C<decoded_fh> instead of C<fh> to
 223 open a filehandle to slurp.  This means if your upload charset is UTF8
 224 we binmode the filehandle to that encoding.
 225
 226 =cut
 227
 228 sub decoded_slurp {
 229     my ( $self, $layer ) = @_;
 230     my $handle = $self->decoded_fh($layer);
 231
 232     my $content = undef;
 233     $handle->seek(0, IO::File::SEEK_SET);
 234     while ( $handle->sysread( my $buffer, 8192 ) ) {
 235         $content .= $buffer;
 236     }
 237
 238     $handle->seek(0, IO::File::SEEK_SET);
 239     return $content;
 240 }
 241
 242 =head2 $upload->basename
 243
 244 Returns basename for C<filename>.  This filters the name through a regexp
 245 C<basename =~ s|[^\w\.-]+|_|g> to make it safe for filesystems that don't
 246 like advanced characters.  This will of course filter UTF8 characters.
 247 If you need the exact basename unfiltered use C<raw_basename>.
 248
 249 =head2 $upload->raw_basename
 250
 251 Just like C<basename> but without filtering the filename for characters that
 252 don't always write to a filesystem.
 253
 254 =head2 $upload->tempname
 255
 256 Returns the path to the temporary file.
 257
 258 =head2 $upload->type
 259
 260 Returns the client-supplied Content-Type.
 261
 262 =head2 $upload->charset
 263
 264 The character set information part of the content type, if any.  Useful if you
 265 need to figure out any encodings on the file upload.
 266
 267 =head2 meta
 268
 269 Provided by Moose
 270
 271 =head1 AUTHORS
 272
 273 Catalyst Contributors, see Catalyst.pm
 274
 275 =head1 COPYRIGHT
 276
 277 This library is free software. You can redistribute it and/or modify
 278 it under the same terms as Perl itself.
 279
 280 =cut
 281
 282 __PACKAGE__->meta->make_immutable;
 283
 284 1;