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 Please note the filename used for the copy target is the 'tempname' that
 103 is the actual filename on the filesystem, NOT the 'filename' that was
 104 part of the upload headers.  This might seem counter intuitive but at this
 105 point this behavior is so established that its not something we can change.
 106
 107 You can always create your own copy routine that munges the target path
 108 as you wish.
 109
 110 =cut
 111
 112 sub copy_to {
 113     my $self = shift;
 114     return File::Copy::copy( $self->tempname, @_ );
 115 }
 116
 117 =head2 $upload->is_utf8_encoded
 118
 119 Returns true of the upload defines a character set at that value is 'UTF-8'.
 120 This does not try to inspect your upload and make any guesses if the Content
 121 Type charset is undefined.
 122
 123 =cut
 124
 125 sub is_utf8_encoded {
 126     my $self = shift;
 127     if(my $charset = $self->charset) {
 128       return $charset eq 'UTF-8' ? 1 : 0;
 129     }
 130     return 0;
 131 }
 132
 133 =head2 $upload->fh
 134
 135 Opens a temporary file (see tempname below) and returns an L<IO::File> handle.
 136
 137 This is a filehandle that is opened with no additional IO Layers.
 138
 139 =head2 $upload->decoded_fh(?$encoding)
 140
 141 Returns a filehandle that has binmode set to UTF-8 if a UTF-8 character set
 142 is found. This also accepts an override encoding value that you can use to
 143 force a particular L<PerlIO> layer.  If neither are found the filehandle is
 144 set to :raw.
 145
 146 This is useful if you are pulling the file into code and inspecting bits and
 147 maybe then sending those bits back as the response.  (Please note this is not
 148 a suitable filehandle to set in the body; use C<fh> if you are doing that).
 149
 150 Please note that using this method sets the underlying filehandle IO layer
 151 so once you use this method if you go back and use the C<fh> method you
 152 still get the IO layer applied.
 153
 154 =cut
 155
 156 sub decoded_fh {
 157     my ($self, $layer) = @_;
 158     my $fh  = $self->fh;
 159
 160     $layer = ":encoding(UTF-8)" if !$layer && $self->is_utf8_encoded;
 161     $layer = ':raw' unless $layer;
 162
 163     binmode($fh, $layer);
 164     return $fh;
 165 }
 166
 167 =head2 $upload->filename
 168
 169 Returns the client-supplied filename.
 170
 171 =head2 $upload->headers
 172
 173 Returns an L<HTTP::Headers> object for the request.
 174
 175 =head2 $upload->link_to
 176
 177 Creates a hard link to the temporary file. Returns true for success,
 178 false for failure.
 179
 180     $upload->link_to('/path/to/target');
 181
 182 =cut
 183
 184 sub link_to {
 185     my ( $self, $target ) = @_;
 186     return CORE::link( $self->tempname, $target );
 187 }
 188
 189 =head2 $upload->size
 190
 191 Returns the size of the uploaded file in bytes.
 192
 193 =head2 $upload->slurp(?$encoding)
 194
 195 Optionally accepts an argument to define an IO Layer (which is applied to
 196 the filehandle via binmode; if no layer is defined the default is set to
 197 ":raw".
 198
 199 Returns a scalar containing the contents of the temporary file.
 200
 201 Note that this will cause the filehandle pointed to by C<< $upload->fh >> to
 202 be reset to the start of the file using seek and the file handle to be put
 203 into whatever encoding mode is applied.
 204
 205 =cut
 206
 207 sub slurp {
 208     my ( $self, $layer ) = @_;
 209
 210     unless ($layer) {
 211         $layer = ':raw';
 212     }
 213
 214     my $content = '';
 215     my $handle  = $self->fh;
 216
 217     binmode( $handle, $layer );
 218
 219     $handle->seek(0, IO::File::SEEK_SET);
 220
 221     if ($layer eq ':raw') {
 222         while ( $handle->sysread( my $buffer, 8192 ) ) {
 223             $content .= $buffer;
 224         }
 225     }
 226     else {
 227         $content = do { local $/; $handle->getline };
 228     }
 229
 230     $handle->seek(0, IO::File::SEEK_SET);
 231     return $content;
 232 }
 233
 234 =head2 $upload->decoded_slurp(?$encoding)
 235
 236 Works just like C<slurp> except we use C<decoded_fh> instead of C<fh> to
 237 open a filehandle to slurp.  This means if your upload charset is UTF8
 238 we binmode the filehandle to that encoding.
 239
 240 =cut
 241
 242 sub decoded_slurp {
 243     my ( $self, $layer ) = @_;
 244     my $handle = $self->decoded_fh($layer);
 245
 246     $handle->seek(0, IO::File::SEEK_SET);
 247
 248     my $content = do { local $/; $handle->getline };
 249
 250     $handle->seek(0, IO::File::SEEK_SET);
 251     return $content;
 252 }
 253
 254 =head2 $upload->basename
 255
 256 Returns basename for C<filename>.  This filters the name through a regexp
 257 C<basename =~ s|[^\w\.-]+|_|g> to make it safe for filesystems that don't
 258 like advanced characters.  This will of course filter UTF8 characters.
 259 If you need the exact basename unfiltered use C<raw_basename>.
 260
 261 =head2 $upload->raw_basename
 262
 263 Just like C<basename> but without filtering the filename for characters that
 264 don't always write to a filesystem.
 265
 266 =head2 $upload->tempname
 267
 268 Returns the path to the temporary file.
 269
 270 =head2 $upload->type
 271
 272 Returns the client-supplied Content-Type.
 273
 274 =head2 $upload->charset
 275
 276 The character set information part of the content type, if any.  Useful if you
 277 need to figure out any encodings on the file upload.
 278
 279 =head2 meta
 280
 281 Provided by Moose
 282
 283 =head1 AUTHORS
 284
 285 Catalyst Contributors, see Catalyst.pm
 286
 287 =head1 COPYRIGHT
 288
 289 This library is free software. You can redistribute it and/or modify
 290 it under the same terms as Perl itself.
 291
 292 =cut
 293
 294 __PACKAGE__->meta->make_immutable;
 295
 296 1;