File Coverage

blib/lib/Catalyst/Request/Upload.pm
Criterion Covered Total %
statement 61 69 88.4
branch 6 12 50.0
condition 1 3 33.3
subroutine 14 16 87.5
pod 6 6 100.0
total 88 106 83.0


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