File Coverage

blib/lib/File/Tabular/Web/Attachments.pm
Criterion Covered Total %
statement 15 113 13.2
branch 0 46 0.0
condition 0 8 0.0
subroutine 5 18 27.7
pod 11 13 84.6
total 31 198 15.6


line stmt bran cond sub pod time code
1             =begin TODO
2              
3             - override "display" to accept V=UploadField
4             => would redirect to attached file
5              
6             - support for multiple files under same field
7              
8             =end TODO
9              
10             =cut
11              
12              
13             package File::Tabular::Web::Attachments;
14 1     1   864 use base 'File::Tabular::Web';
  1         2  
  1         74  
15 1     1   5 use strict;
  1         1  
  1         16  
16 1     1   5 use warnings;
  1         1  
  1         30  
17              
18 1     1   6 use File::Path;
  1         2  
  1         51  
19 1     1   4 use Scalar::Util qw/looks_like_number/;
  1         2  
  1         1157  
20              
21              
22             #----------------------------------------------------------------------
23             sub app_initialize {
24             #----------------------------------------------------------------------
25 0     0 1   my $self = shift;
26              
27 0           $self->SUPER::app_initialize;
28              
29             # field names specified as "upload fields" in config
30 0           $self->{app}{upload_fields} = $self->{app}{cfg}->get('fields_upload');
31             }
32              
33              
34             #----------------------------------------------------------------------
35             sub open_data {
36             #----------------------------------------------------------------------
37 0     0 1   my $self = shift;
38              
39 0           $self->SUPER::open_data;
40              
41             # upload fields must be present in the data file
42 0           my %data_headers = map {$_ => 1} $self->{data}->headers;
  0            
43 0           my @upld = keys %{$self->{app}{upload_fields}};
  0            
44 0           my $invalid = join ", ", grep {not $data_headers{$_}} @upld;
  0            
45 0 0         die "upload fields in config but not in data file: $invalid" if $invalid;
46             }
47              
48              
49             #----------------------------------------------------------------------
50             sub before_update { #
51             #----------------------------------------------------------------------
52 0     0 1   my ($self, $record) = @_;
53            
54 0           my @upld = keys %{$self->{app}{upload_fields}};
  0            
55              
56             # remember paths and names of old files (in case we must delete them later)
57 0           foreach my $field (grep {$record->{$_}} @upld) {
  0            
58 0           $self->{old_name}{$field} = $record->{$field};
59 0           $self->{old_path}{$field} = $self->upload_fullpath($record, $field);
60             }
61              
62             # call parent method
63 0           $self->SUPER::before_update($record);
64              
65             # find out about next autoNum (WARN: breaks encapsulation of File::Tabular!)
66 0 0         if ($self->{cfg}->get('fields_autoNum')) {
67 0           $self->{next_autoNum} = $self->{data}{autoNum};
68             }
69              
70             # now deal with file uploads
71 0           foreach my $field (@upld) {
72            
73 0           my $remote_name = $self->param($field);
74             # If we have a Plack::Request , use the uploads func to
75             # retrieve the file that was uploaded
76 0 0 0       if(!$remote_name && $self->{req}) {
77 0           my $upload = $self->{req}->uploads->{$field};
78 0 0         $remote_name = $upload->basename if ($upload);
79             }
80 0 0         if ($remote_name) {
81 0           $self->do_upload_file($record, $field, $remote_name);
82             }
83             else { # upload is "" ==> must restore old name in record
84 0   0       $record->{$field} = $self->{old_name}{$field} || "";
85             }
86             };
87             }
88              
89             #----------------------------------------------------------------------
90             sub do_upload_file { #
91             #----------------------------------------------------------------------
92 0     0 1   my ($self, $record, $field, $remote_name) = @_;
93              
94 0           my $src_fh;
95              
96 0 0         if ($self->{modperl}) {
97 0           require Apache2::Request;
98 0           require Apache2::Upload;
99 0           my $req = Apache2::Request->new($self->{modperl});
100 0 0         my $upld = $req->upload($field) or die "no upload object for field $field";
101 0           $src_fh = $upld->fh;
102             }
103             else {
104 0           my @uploads = $self->{req}->upload($field); # may be an array
105 0           my @upld_fh = map { $_->path } @uploads;
  0            
106              
107             # TODO : some convention for deleting an existing attached file
108             # if @upload_fh == 0 && $remote_name =~ /^( |del)/ {...}
109              
110             # no support at the moment for multiple files under same field
111 0 0         @upld_fh < 2 or die "several files uploaded to $field";
112            
113             # need to open the filehandle to reproduce Apache2::Upload's behaviour
114 0 0         open $src_fh, "<$upld_fh[0]" or die "open <$upld_fh[0] : $!";
115            
116             }
117              
118             # compute server name and server path
119 0           $record->{$field}
120             = $self->generate_upload_name($record, $field, $remote_name);
121 0           my $path = $self->upload_fullpath($record, $field);
122 0           my $old_path = $self->{old_path}{$field};
123              
124             # avoid clobbering existing files
125 0 0 0       not -e $path or $path eq $old_path
126             or die "upload $field : file $path already exists";
127              
128             # check that upload path is unique
129 0 0         not exists $self->{results}{uploaded}{$path}
130             or die "multiple uploads to same server location : $path";
131              
132             # remember new and old path
133 0           $self->{results}{uploaded}{$path} = {field => $field,
134             old_path => $old_path};
135              
136             # do the transfer
137 0           my ($dir) = ($path =~ m[^(.*)[/\\]]);
138 0 0         -d $dir or mkpath $dir; # will die if can't make path
139            
140 0 0         open my $dest_fh, ">$path.new" or die "open >$path.new : $!";
141            
142 0           binmode($dest_fh), binmode($src_fh);
143 0           my $buf;
144 0           while (read($src_fh, $buf, 4096)) { print $dest_fh $buf;}
  0            
145              
146 0           $self->{msg} .= "file $remote_name uploaded to $path
";
147             }
148              
149              
150             #----------------------------------------------------------------------
151             sub after_update {
152             #----------------------------------------------------------------------
153 0     0 1   my ($self, $record) = @_;
154              
155 0           my $uploaded = $self->{results}{uploaded};
156              
157             # rename uploaded files and delete old versions
158 0           while (my ($path, $info) = each %$uploaded) {
159 0           my $field = $info->{field};
160 0           my $old_path = $info->{old_path};
161              
162 0 0         $self->before_delete_attachment($record, $field, $old_path)
163             if $old_path;
164              
165 0 0         rename "$path.new", "$path" or die "rename $path.new => $path : $!";
166              
167 0 0         if ($old_path) {
168 0 0         if ($old_path eq $path) {
169 0           $self->{msg} .= "old file $old_path has been replaced
";
170             }
171             else {
172 0           my $unlink_ok = unlink $old_path;
173 0 0         $self->{msg} .= $unlink_ok ? "
removed old file $old_path
"
174             : "
remove $old_path : $^E
";
175             }
176             }
177 0           $self->after_add_attachment($record, $field, $path);
178             }
179             }
180              
181              
182              
183              
184             #----------------------------------------------------------------------
185             sub rollback_update { # undo what was done by "before_update"
186             #----------------------------------------------------------------------
187 0     0 1   my ($self, $record) = @_;
188 0           my $uploaded = $self->{results}{uploaded};
189 0           foreach my $path (keys %$uploaded) {
190 0           unlink("$path.new");
191             }
192             }
193              
194              
195              
196              
197             #----------------------------------------------------------------------
198             sub after_delete {
199             #----------------------------------------------------------------------
200 0     0 1   my ($self, $record)= @_;
201              
202 0           $self->SUPER::after_delete($record);
203              
204             # suppress files attached to deleted record
205 0           my @upld = keys %{$self->{app}{upload_fields}};
  0            
206 0           foreach my $field (@upld) {
207 0 0         my $path = $self->upload_fullpath($record, $field)
208             or next;
209              
210 0           $self->before_delete_attachment($record, $path);
211 0           my $unlink_ok = unlink "$path";
212 0 0         my $msg = $unlink_ok ? "was suppressed" : "couldn't be suppressed ($!)";
213 0           $self->{msg} .= "
Attached file $path $msg";
214             }
215             }
216              
217              
218             #----------------------------------------------------------------------
219             sub generate_upload_name {
220             #----------------------------------------------------------------------
221 0     0 1   my ($self, $record, $field, $remote_name)= @_;
222              
223             # just keep the trailing part of the remote name
224 0           $remote_name =~ s{^.*[/\\]}{};
225 0           return $remote_name;
226             }
227              
228              
229             #----------------------------------------------------------------------
230             sub upload_path {
231             #----------------------------------------------------------------------
232 0     0 1   my ($self, $record, $field)= @_;
233              
234 0 0         return "" if not $record->{$field};
235              
236             # get the id of that record; if creating, cheat by guessing next autoNum
237 0           my $autonum_char = $self->{data}{autoNumChar};
238 0           (my $key = $self->key($record)) =~ s/$autonum_char/$self->{next_autoNum}/;
239              
240 0 0         my $dir = looks_like_number($key) ? sprintf "%05d/", int($key / 100)
241             : "";
242              
243 0           return "${field}/${dir}${key}_$record->{$field}";
244             }
245              
246              
247             #----------------------------------------------------------------------
248             sub upload_fullpath {
249             #----------------------------------------------------------------------
250 0     0 1   my ($self, $record, $field)= @_;
251 0           my $path = $self->upload_path($record, $field);
252 0 0         return $path ? "$self->{app}{dir}$path" : "";
253             }
254              
255              
256             #----------------------------------------------------------------------
257             sub download { # default implementation; override in subclasses
258             #----------------------------------------------------------------------
259 0     0 1   my ($self, $record, $field)= @_;
260              
261 0           return $self->upload_path($record, $field); # relative to app URL
262             }
263              
264              
265              
266              
267       0 0   sub after_add_attachment {}
268       0 0   sub before_delete_attachment {}
269              
270              
271              
272              
273              
274              
275              
276             1;
277              
278             __END__