File Coverage

blib/lib/HTML/FormFu/Constraint/File/MIME.pm
Criterion Covered Total %
statement 27 29 93.1
branch 9 12 75.0
condition 4 6 66.6
subroutine 7 7 100.0
pod 0 1 0.0
total 47 55 85.4


line stmt bran cond sub pod time code
1 2     2   1207 use strict;
  2         11  
  2         147  
2              
3             package HTML::FormFu::Constraint::File::MIME;
4             $HTML::FormFu::Constraint::File::MIME::VERSION = '2.07';
5             # ABSTRACT: MIME Type Constraint
6              
7 2     2   22 use Moose;
  2         6  
  2         16  
8 2     2   13269 use MooseX::Attribute::Chained;
  2         5  
  2         99  
9             extends 'HTML::FormFu::Constraint';
10              
11 2     2   13 use List::Util 1.33 qw( any );
  2         67  
  2         209  
12 2     2   20 use Scalar::Util qw( blessed );
  2         5  
  2         633  
13              
14             has regex => ( is => 'rw', traits => ['Chained'] );
15             has types => ( is => 'rw', traits => ['Chained'] );
16              
17             sub constrain_value {
18 4     4 0 9 my ( $self, $value ) = @_;
19              
20 4 100 66     18 return 1 if !defined $value || $value eq '';
21              
22 3 100 66     20 return if !blessed($value) || !$value->isa('HTML::FormFu::Upload');
23              
24 2         55 my $input = $value->headers->content_type;
25 2         82 my $types = $self->types;
26 2         49 my $regex = $self->regex;
27              
28 2 100       5 if ( defined $types ) {
29 1 50       4 if ( ref $types ne 'ARRAY' ) {
30 0         0 $types = [$types];
31             }
32              
33 1 50   2   7 return 1 if any { $input eq $_ } @$types;
  2         10  
34             }
35              
36 1 50       5 if ( defined $regex ) {
37 1         38 return $input =~ /$regex/x;
38             }
39              
40 0           return;
41             }
42              
43             __PACKAGE__->meta->make_immutable;
44              
45             1;
46              
47             __END__
48              
49             =pod
50              
51             =encoding UTF-8
52              
53             =head1 NAME
54              
55             HTML::FormFu::Constraint::File::MIME - MIME Type Constraint
56              
57             =head1 VERSION
58              
59             version 2.07
60              
61             =head1 DESCRIPTION
62              
63             Constraint an uploaded file's MIME-type (Content-Type).
64              
65             L</types> is checked before L</regex>.
66              
67             =head1 METHODS
68              
69             =head2 types
70              
71             Arguments: $mime_type
72              
73             Arguments: \@mime_types
74              
75             Optional.
76              
77             Accepts a single MIME-type or an arrayref of MIME-types. Each is checked
78             against the uploaded file's MIME-type (as given by the browser), and the
79             constraint passes if any one of the given types matches.
80              
81             =head2 regex
82              
83             Arguments: $regex
84              
85             Optional.
86              
87             Accepts a string to be interpreted as a regex, and is checked against the
88             uploaded files's MIME-type (as given by the browser).
89              
90             The regex uses the C</x> flag, so that whitespace in the given string is
91             ignored.
92              
93             =head1 SEE ALSO
94              
95             Is a sub-class of, and inherits methods from L<HTML::FormFu::Constraint>
96              
97             L<HTML::FormFu>
98              
99             =head1 AUTHOR
100              
101             Carl Franks, C<cfranks@cpan.org>
102              
103             =head1 LICENSE
104              
105             This library is free software, you can redistribute it and/or modify it under
106             the same terms as Perl itself.
107              
108             =head1 AUTHOR
109              
110             Carl Franks <cpan@fireartist.com>
111              
112             =head1 COPYRIGHT AND LICENSE
113              
114             This software is copyright (c) 2018 by Carl Franks.
115              
116             This is free software; you can redistribute it and/or modify it under
117             the same terms as the Perl 5 programming language system itself.
118              
119             =cut