File Coverage

blib/lib/MVC/Neaf/Upload.pm
Criterion Covered Total %
statement 55 59 93.2
branch 12 22 54.5
condition 1 6 16.6
subroutine 12 12 100.0
pod 7 7 100.0
total 87 106 82.0


line stmt bran cond sub pod time code
1             package MVC::Neaf::Upload;
2              
3 97     97   224930 use strict;
  97         252  
  97         2996  
4 97     97   510 use warnings;
  97         199  
  97         3959  
5              
6             =head1 NAME
7              
8             MVC::Neaf::Upload - File upload object for Not Even A Framework
9              
10             =head1 METHODS
11              
12             Generally, this class isn't used directly; instead, it's returned by an
13             L object.
14              
15             =cut
16              
17             our $VERSION = '0.2800_01';
18 97     97   571 use Carp;
  97         211  
  97         5219  
19 97     97   1713 use Encode;
  97         31504  
  97         7286  
20 97     97   44109 use PerlIO::encoding;
  97         41641  
  97         64777  
21              
22             =head2 new(%options)
23              
24             %options may include:
25              
26             =over
27              
28             =item * id (required) - the form id by which upload is known.
29              
30             =item * tempfile - file where upload is stored.
31              
32             =item * handle - file handle opened for readin. One of these is required.
33              
34             =item * filename - user-supplied filename. Don't trust this.
35              
36             =item * utf8 - if set, all data read from the file will be utf8-decoded.
37              
38             =back
39              
40             =cut
41              
42             # TODO 0.30 figure out if GLOBs are worth the hassle
43             # We use GLOB objects so that <$upload> works as expected.
44             # This may turn out to be not worth it, so it's not even in the docs yet.
45             # See also t/*diamond*.t
46              
47             my %new_opt;
48             my @copy_fields = qw(id tempfile filename utf8);
49             $new_opt{$_}++ for @copy_fields, "handle";
50             sub new {
51 7     7 1 8417 my ($class, %args) = @_;
52              
53             # TODO 0.30 add "unicode" flag to open & slurp in utf8 mode
54              
55 7         27 my @extra = grep { !$new_opt{$_} } keys %args;
  18         52  
56 7 50       26 croak( "$class->new(): unknown options @extra" )
57             if @extra;
58             defined $args{id}
59 7 50       21 or croak( "$class->new(): id option is required" );
60              
61 7         11 my $self;
62 7 50       27 if ($args{tempfile}) {
    50          
63             open $self, "<", $args{tempfile}
64 0 0       0 or croak "$class->new(): Failed to open $args{tempfile}: $!";
65             } elsif ($args{handle}) {
66             open $self, "<&", $args{handle}
67 7 50       148 or croak "$class->new(): Failed to dup handle $args{handle}: $!";
68             } else {
69 0         0 croak( "$class->new(): Either tempfile or handle option required" );
70             };
71              
72 7 100       31 if ($args{utf8}) {
73 2         3 local $PerlIO::encoding::fallback = Encode::FB_CROAK;
74 2         16 binmode $self, ":encoding(UTF-8)"
75             };
76 7         301 bless $self, $class;
77              
78             *$self->{$_} = $args{$_}
79 7         68 for @copy_fields;
80              
81 7         42 return $self;
82             };
83              
84             =head2 id()
85              
86             Return upload id.
87              
88             =cut
89              
90             sub id {
91 2     2 1 14 my $self = shift;
92 2         12 return *$self->{id};
93             };
94              
95             =head2 filename()
96              
97             Get user-supplied file name. Don't trust this value.
98              
99             =cut
100              
101             sub filename {
102 2     2 1 686 my $self = shift;
103              
104 2 50       12 *$self->{filename} = '/dev/null' unless defined *$self->{filename};
105 2         8 return *$self->{filename};
106             };
107              
108             =head2 size()
109              
110             Calculate file size.
111              
112             B May return 0 if file is a pipe.
113              
114             =cut
115              
116             sub size {
117 1     1 1 3 my $self = shift;
118              
119 1   33     7 return *$self->{size} ||= do {
120             # calc size
121 1         3 my $fd = $self->handle;
122 1         14 my @stat = stat $fd;
123 1 50       10 $stat[7] || 0;
124             };
125             };
126              
127             =head2 handle()
128              
129             Return file handle, opening temp file if needed.
130              
131             =cut
132              
133             sub handle {
134 15     15 1 33 my $self = shift;
135              
136 15         27 return $self;
137             };
138              
139             =head2 content()
140              
141             Return file content (aka slurp), caching it in memory.
142              
143             B May eat up a lot of memory. Be careful...
144              
145             B This breaks file current position, resetting it to the beginning.
146              
147             =cut
148              
149             sub content {
150 7     7 1 35 my $self = shift;
151              
152             # TODO 0.30 remember where the file was 1st time
153 7 100       24 if (!defined *$self->{content}) {
154 5         17 $self->rewind;
155 5         13 my $fd = $self->handle;
156              
157 5         19 local $/;
158 5         66 my $content = <$fd>;
159 4 50       26 if (!defined $content) {
160 0   0     0 my $fname = *$self->{tempfile} || $fd;
161 0         0 croak( "Upload *$self->{id}: failed to read file $fname: $!");
162             };
163              
164 4         12 $self->rewind;
165 4         16 *$self->{content} = $content;
166             };
167              
168 6         75 return *$self->{content};
169             };
170              
171             =head2 rewind()
172              
173             Reset the file to the beginning. Will fail silently on pipes.
174              
175             Returns self.
176              
177             =cut
178              
179             sub rewind {
180 9     9 1 13 my $self = shift;
181              
182 9         19 my $fd = $self->handle;
183 9         32 seek $fd, 0, 0;
184 9         15 return $self;
185             };
186              
187             # TODO 0.30 kill the tempfile, if any?
188             # sub DESTROY { };
189              
190             =head1 LICENSE AND COPYRIGHT
191              
192             This module is part of L suite.
193              
194             Copyright 2016-2023 Konstantin S. Uvarin C.
195              
196             This program is free software; you can redistribute it and/or modify it
197             under the terms of either: the GNU General Public License as published
198             by the Free Software Foundation; or the Artistic License.
199              
200             See L for more information.
201              
202             =cut
203              
204             1;