File Coverage

blib/lib/Data/FormValidator/Constraints/Upload.pm
Criterion Covered Total %
statement 145 165 87.8
branch 25 52 48.0
condition 28 48 58.3
subroutine 20 20 100.0
pod 4 8 50.0
total 222 293 75.7


line stmt bran cond sub pod time code
1             package Data::FormValidator::Constraints::Upload;
2 3     3   148463 use Exporter 'import';
  3         9  
  3         101  
3 3     3   14 use strict;
  3         6  
  3         1261  
4              
5             # Items to export into callers namespace by default. Note: do not export
6             # names by default without a very good reason. Use EXPORT_OK instead.
7             # Do not simply export all your public functions/methods/constants.
8              
9             # This allows declaration use Data::FormValidator::Constraints::Upload ':all';
10             # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
11             # will save memory.
12              
13             our @EXPORT = qw(
14             valid_file_format
15             valid_image_max_dimensions
16             valid_file_max_bytes
17             valid_image_min_dimensions
18             );
19              
20             our @EXPORT_OK = qw(
21             file_format
22             image_max_dimensions
23             file_max_bytes
24             image_min_dimensions
25             );
26              
27             our $VERSION = 4.88;
28              
29             sub file_format {
30 5     5 1 11840 my %params = @_;
31             return sub {
32 5     5   8 my $self = shift;
33 5         16 $self->set_current_constraint_name('file_format');
34 5         14 valid_file_format($self,\%params);
35             }
36 5         27 }
37              
38             sub image_max_dimensions {
39 5   50 5 1 692 my $w = shift || die 'image_max_dimensions: missing maximum width value';
40 5   50     13 my $h = shift || die 'image_max_dimensions: missing maximum height value';
41             return sub {
42 6     6   10 my $self = shift;
43 6         17 $self->set_current_constraint_name('image_max_dimensions');
44 6         17 valid_image_max_dimensions($self,\$w,\$h);
45             }
46 5         29 }
47              
48             sub file_max_bytes {
49 2     2 1 4 my ($max_bytes) = @_;
50             return sub {
51 2     2   4 my $self = shift;
52 2         7 $self->set_current_constraint_name('file_max_bytes');
53 2         7 valid_file_max_bytes($self,\$max_bytes);
54             }
55 2         17 }
56              
57             sub image_min_dimensions {
58 2   50 2 1 4 my $w = shift || die 'image_min_dimensions: missing minimum width value';
59 2   50     6 my $h = shift || die 'image_min_dimensions: missing minimum height value';
60             return sub {
61 2     2   4 my $self = shift;
62 2         6 $self->set_current_constraint_name('image_min_dimensions');
63 2         6 valid_image_min_dimensions($self,\$w,\$h);
64             }
65 2         10 }
66              
67             sub valid_file_format {
68 8     8 0 13 my $self = shift;
69 8 50       34 $self->isa('Data::FormValidator::Results') ||
70             die "file_format: first argument is not a Data::FormValidator::Results object. ";
71 8   100     25 my $params = shift || {};
72             # if (ref $params ne 'HASH' ) {
73             # die "format: hash reference expected. Make sure you have
74             # included 'params => []' in your constraint definition, even if there
75             # are no additional arguments";
76             # }
77 8         26 my $q = $self->get_filtered_data;
78              
79 8         22 my $field = $self->get_current_constraint_field;
80 8         20 my $fh = _get_upload_fh($self);
81              
82             ## load filehandle
83 8 50       501 if (!$fh) {
84 0 0       0 warn "$0: can't get filehandle for field named $field" and return undef;
85             }
86              
87             ## load file magic stuff
88 8         939 require File::MMagic;
89 8         10554 my $mm = File::MMagic->new;
90 8         3207 my $fm_mt;
91              
92             ## only use filehandle bits for magic data
93 8   33     26 $fm_mt = $mm->checktype_filehandle($fh) ||
94             (warn "$0: can't get filehandle for field named $field" and return undef);
95             # Work around a bug in File::MMagic (RT#12074)
96 8         121811 seek($fh,0,0);
97              
98             # File::MMagic returns 'application/octet-stream" as a punt
99             # for "I don't know, here's a generic binary MIME type.
100             # In some cases that is has indicated a bug in File::MMagic,
101             # but it's a generally worthless response for identifying the file type.
102             # so, we throw away the response in that case. The uploaded MIME type
103             # will be used instead later, if present
104 8 50       29 $fm_mt = undef if ($fm_mt eq 'application/octet-stream');
105              
106              
107             ## fetch mime type universally (or close)
108 8         29 my $uploaded_mt = _get_upload_mime_type($self);
109              
110             # try the File::MMagic, then the uploaded field, then return undef we find neither
111 8 50 33     196 my $mt = ($fm_mt || $uploaded_mt) or return undef;
112              
113             # figure out an extension
114 3     3   752 use MIME::Types;
  3         11978  
  3         2740  
115 8         61 my $mimetypes = MIME::Types->new;
116 8         83594 my MIME::Type $t = $mimetypes->type($mt);
117 8 50       499 my @mt_exts = $t ? $t->extensions : ();
118              
119             ## setup filename to retrieve extension
120 8         111 my $fn = $self->get_input_data->param($field);
121 8         190 my ($uploaded_ext) = ($fn =~ m/\.([\w\d]*)?$/);
122 8         131 my $ext;
123              
124 8 50       25 if (scalar @mt_exts) {
125             # If the upload extension is one recognized by MIME::Type, use it.
126 8 100       20 if (grep {/^$uploaded_ext$/} @mt_exts) {
  48         224  
127 6         68 $ext = $uploaded_ext;
128             }
129             # otherwise, use one from MIME::Type, just to be safe
130             else {
131 2         6 $ext = $mt_exts[0];
132             }
133             }
134             else {
135             # If is a provided extension but no MIME::Type extension, use that.
136             # It's possible that there no extension uploaded or found)
137 0         0 $ext = $uploaded_ext;
138             }
139              
140             # Add the mime_type and extension to the valid data set
141 8   50     77 my $info = $self->meta($field) || {};
142 8         51 $info = { %$info, mime_type => $mt, extension => ".$ext" };
143 8         30 $self->meta($field,$info);
144              
145 8         24 return _is_allowed_type($mt, $params);
146             }
147              
148             ## Returns true if the passed-in mime-type matches our allowed types
149             sub _is_allowed_type {
150 12     12   431 my $mt = shift;
151 12         21 my $params = shift;
152              
153             # XXX perhaps this should be in a global variable so it's easier
154             # for other apps to change the defaults;
155 12   100     75 $params->{mime_types} ||= [qw!image/jpeg image/pjpeg image/gif image/png!];
156 12         21 my %allowed_types = map { $_ => 1 } @{ $params->{mime_types} };
  42         99  
  12         28  
157              
158 12         549 return $allowed_types{lc $mt};
159             }
160              
161              
162             sub valid_image_max_dimensions {
163 10     10 0 17 my $self = shift;
164 10 50       36 $self->isa('Data::FormValidator::Results') ||
165             die "image_max_dimensions: first argument is not a Data::FormValidator::Results object. ";
166 10   50     24 my $max_width_ref = shift || die 'image_max_dimensions: missing maximum width value';
167 10   50     20 my $max_height_ref = shift || die 'image_max_dimensions: missing maximum height value';
168 10         15 my $max_width = $$max_width_ref;
169 10         13 my $max_height = $$max_height_ref;
170 10 50       22 ($max_width > 0) || die 'image_max_dimensions: maximum width must be > 0';
171 10 50       20 ($max_height > 0) || die 'image_max_dimensions: maximum height must be > 0';
172              
173 10         22 my $q = $self->get_filtered_data;
174 10         22 my $field = $self->get_current_constraint_field;
175 10         24 my ($width,$height) = _get_img_size($self);
176              
177 10 50       22 unless ($width) {
178 0         0 warn "$0: imgsize test failed";
179 0         0 return undef;
180             }
181              
182             # Add the dimensions to the valid hash
183 10   50     42 my $info = $self->meta($field) || {};
184 10         44 $info = { %$info, width => $width, height => $height };
185 10         30 $self->meta($field,$info);
186              
187 10   66     45 return (($width <= $$max_width_ref) and ($height <= $$max_height_ref));
188             }
189              
190             sub valid_file_max_bytes {
191 4     4 0 7 my $self = shift;
192              
193 4 50       20 $self->isa('Data::FormValidator::Results') ||
194             die "first argument is not a Data::FormValidator::Results object.";
195              
196 4         8 my $max_bytes_ref = shift;
197 4         6 my $max_bytes;
198              
199 4 100 100     19 if ((ref $max_bytes_ref) and defined $$max_bytes_ref) {
200 2         5 $max_bytes = $$max_bytes_ref;
201             }
202             else {
203 2         6 $max_bytes = 1024*1024; # default to 1 Meg
204             }
205              
206 4         12 my $q = $self->get_filtered_data;
207              
208 4         12 my $field = $self->get_current_constraint_field;
209              
210             ## retrieve upload fh for field
211 4         14 my $fh = _get_upload_fh($self);
212 4 50 0     315 if (!$fh) { warn "Failed to load filehandle for $field" && return undef; }
  0         0  
213              
214             ## retrieve size
215 4         26 my $file_size = (stat ($fh))[7];
216              
217             # Add the size to the valid hash
218 4   100     15 my $info = $self->meta($field) || {};
219 4         27 $info = { %$info, bytes => $file_size };
220 4         14 $self->meta($field,$info);
221              
222 4         20 return ($file_size <= $max_bytes);
223             }
224              
225             sub valid_image_min_dimensions {
226 4     4 0 7 my $self = shift;
227 4 50       21 $self->isa('Data::FormValidator::Results') ||
228             die "image_min_dimensions: first argument is not a Data::FormValidator::Results object. ";
229 4   50     8 my $min_width_ref = shift ||
230             die 'image_min_dimensions: missing minimum width value';
231 4   50     10 my $min_height_ref = shift ||
232             die 'image_min_dimensions: missing minimum height value';
233 4         6 my $min_width = $$min_width_ref;
234 4         7 my $min_height = $$min_height_ref;
235              
236             ## do these matter?
237 4 50       8 ($min_width > 0) || die 'image_min_dimensions: minimum width must be > 0';
238 4 50       9 ($min_height > 0) || die 'image_min_dimensions: minimum height must be > 0';
239              
240 4         7 my $q = $self->get_filtered_data;
241 4         7 my $field = $self->get_current_constraint_field;
242 4         9 my ($width, $height) = _get_img_size($self);
243              
244 4 50       12 unless ($width) {
245 0         0 warn "image failed processing";
246 0         0 return undef;
247             }
248              
249             # Add the dimensions to the valid hash
250 4   100     12 my $info = $self->meta($field) || {};
251 4         15 $info = { %$info, width => $width, height => $height };
252 4         12 $self->meta($field,$info);
253              
254 4   66     19 return (($width >= $min_width) and ($height >= $min_height));
255             }
256              
257             sub _get_img_size
258             {
259 14     14   18 my $self = shift;
260 14         27 my $q = $self->get_filtered_data;
261              
262             ## setup caller to make can errors more useful
263 14         56 my $caller = (caller(1))[3];
264 14         29 my $pkg = __PACKAGE__ . "::";
265 14         80 $caller =~ s/$pkg//g;
266              
267 14         31 my $field = $self->get_current_constraint_field;
268              
269             ## retrieve filehandle from query object.
270 14         30 my $fh = _get_upload_fh($self);
271              
272             ## check error
273 14 50       807 if (not $fh) {
274 0         0 warn "Unable to load filehandle";
275 0         0 return undef;
276             }
277              
278 14         883 require Image::Size;
279 14         6902 import Image::Size;
280              
281             ## check size
282 14         43 my ($width, $height, $err) = imgsize($fh);
283              
284 14 50       1243 unless ($width) {
285 0         0 warn "$caller: imgsize test failed: $err";
286 0         0 return undef;
287             }
288              
289 14         67 return ($width, $height);
290             }
291              
292             ## fetch filehandle for use with various file type checking
293             ## call it with (_get_upload_fh($self)) since kind of mock object
294             sub _get_upload_fh
295             {
296 26     26   36 my $self = shift;
297 26         52 my $q = $self->get_filtered_data;
298 26         47 my $field = $self->get_current_constraint_field;
299              
300             # convert the FH for the filtered data into a -seekable- handle;
301             # depending on whether we're using CGI::Simple, CGI, or Apache::Request
302             # we might not have something -seekable-.
303 3     3   1005 use IO::File;
  3         20117  
  3         917  
304              
305             # If we we already have an IO::File object, return it, otherwise create one.
306 26         136 require Scalar::Util;
307              
308 26 50 33     214 if ( Scalar::Util::blessed($q->{$field}) && $q->{$field}->isa('IO::File') ) {
309 0         0 return $q->{$field};
310             }
311             else {
312 26         133 return IO::File->new_from_fd(fileno($q->{$field}), 'r');
313             }
314             }
315              
316             ## returns mime type if included as part of the send
317             ##
318             ## NOTE: retrieves from original uploaded, -UNFILTERED- data
319             sub _get_upload_mime_type
320             {
321 8     8   17 my $self = shift;
322 8         45 my $q = $self->get_input_data;
323 8         30 my $field = $self->get_current_constraint_field;
324              
325 8 50       63 if ($q->isa('CGI')) {
326 8         54 my $fn = $q->param($field);
327              
328             ## nicely check for info
329 8 50       240 if ($q->uploadInfo($fn)) {
330 8         336 return $q->uploadInfo($fn)->{'Content-Type'}
331             }
332              
333 0           return undef;
334             }
335              
336 0 0         if ($q->isa('CGI::Simple')) {
337 0           my $fn = $q->param($field);
338 0           return $q->upload_info($fn, 'mime');
339             }
340              
341 0 0         if ($q->isa('Apache::Request')) {
342 0           my $upload = $q->upload($field);
343 0           return $upload->info('Content-type');
344             }
345              
346 0           return undef;
347             }
348              
349              
350             1;
351             __END__