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