78eb91067235ba82399ce71999b3e7185b44a9d2
[bse.git] / site / cgi-bin / modules / BSE / TB / ArticleFile.pm
1 package BSE::TB::ArticleFile;
2 use strict;
3 # represents a file associated with an article from the database
4 use base qw(Squirrel::Row BSE::MetaOwnerBase);
5 use Carp 'confess';
6
7 our $VERSION = "1.011";
8
9 sub columns {
10   return qw/id articleId displayName filename sizeInBytes description 
11             contentType displayOrder forSale download whenUploaded
12             requireUser notes name hide_from_list storage src category
13             file_handler/;
14 }
15
16 sub table {
17   "article_files";
18 }
19
20 sub defaults {
21   require BSE::Util::SQL;
22   return
23     (
24      notes => '',
25      description => '',
26      name => '',
27      whenUploaded => BSE::Util::SQL::now_datetime(),
28      displayOrder => time,
29      src => '',
30      file_handler => '',
31      forSale => 0,
32      download => 0,
33      requireUser => 0,
34      hide_from_list => 0,
35      category => '',
36      storage => 'local',
37     );
38 }
39
40 sub full_filename {
41   my ($self, $cfg) = @_;
42
43   $cfg ||= BSE::Cfg->single;
44
45   my $downloadPath = BSE::TB::ArticleFiles->download_path($cfg);
46   return $downloadPath . "/" . $self->{filename};
47 }
48
49 sub file_exists {
50   my ($self, $cfg) = @_;
51
52   return -f $self->full_filename($cfg);
53 }
54
55 sub remove {
56   my ($self, $cfg) = @_;
57
58   $self->clear_metadata;
59
60   $cfg or confess "No \$cfg supplied to ",ref $self,"->remove()";
61
62   my $filename = $self->full_filename($cfg);
63   my $debug_del = $cfg->entryBool('debug', 'file_unlink', 0);
64   if ($debug_del) {
65     unlink $filename
66       or print STDERR "Error deleting $filename: $!\n";
67   }
68   else {
69     unlink $filename;
70   }
71   
72   $self->SUPER::remove();
73 }
74
75 sub article {
76   my $self = shift;
77   require BSE::TB::Articles;
78
79   return BSE::TB::Articles->getByPkey($self->{articleId});
80 }
81
82 sub url {
83   my ($file, $cfg) = @_;
84
85  #   return "/cgi-bin/user.pl/download_file/$file->{id}";
86
87   $cfg ||= BSE::Cfg->single;
88
89   if ($file->storage eq "local" 
90       || $file->forSale
91       || $file->requireUser
92       || $cfg->entryBool("downloads", "require_logon", 0)
93       || $cfg->entry("downloads", "always_redirect", 0)) {
94     return "/cgi-bin/user.pl/download_file/$file->{id}";
95   }
96   else {
97     return $file->src;
98   }
99 }
100
101 sub handler {
102   my ($self, $cfg) = @_;
103
104   return BSE::TB::ArticleFiles->handler($self->file_handler, $cfg);
105 }
106
107 sub set_handler {
108   my ($self, $cfg) = @_;
109
110   my %errors; # save for later setting into the metadata
111
112   for my $handler_entry (BSE::TB::ArticleFiles->file_handlers($cfg)) {
113     my ($key, $handler) = @$handler_entry;
114     my $success = eval {
115       $self->clear_sys_metadata;
116       $handler->process_file($self);
117       1;
118     };
119     if ($success) {
120       # set errors from handlers that failed
121       for my $key (keys %errors) {
122         $self->add_meta(name => "${key}_error",
123                         value => $errors{$key},
124                         appdata => 0);
125       }
126       $self->set_file_handler($key);
127
128       return;
129     }
130     else {
131       $errors{$key} = $@;
132       chomp $errors{$key};
133     }
134   }
135
136   # we should never get here
137   $self->set_file_handler("");
138   print STDERR "** Ran off the end of ArticleFile->set_handler()\n";
139   return;
140 }
141
142 sub inline {
143   my ($file, %opts) = @_;
144
145   my $cfg = delete $opts{cfg}
146     or confess "Missing cfg parameter";
147
148   my $field = delete $opts{field};
149   defined $field or $field = "";
150
151   if ($field && exists $file->{$field}) {
152     require BSE::Util::HTML;
153     return BSE::Util::HTML::escape_html($file->{$field});
154   }
155   elsif ($field =~ /^meta\.(\w+)$/) {
156     my $name = $1;
157     my $meta = $file->meta_by_name($name)
158       or return "";
159     $meta->content_type eq "text/plain"
160       or return "* metadata $name isn't text *";
161
162     require BSE::Util::HTML;
163     return BSE::Util::HTML::escape_html($meta->value);
164   }
165   elsif ($field eq "link" || $field eq "url") {
166     my $url = "/cgi-bin/user.pl?download_file=1&file=$file->{id}";
167     require BSE::Util::HTML;
168     my $eurl = BSE::Util::HTML::escape_html($url);
169     if ($field eq 'url') {
170       return $eurl;
171     }
172     my $class = $file->{download} ? "file_download" : "file_inline";
173     my $html = qq!<a class="$class" href="$eurl">! . BSE::Util::HTML::escape_html($file->{displayName}) . '</a>';
174     return $html;
175   }
176   else {
177     my $handler = $file->handler($cfg);
178     return $handler->inline($file, $field);
179   }
180
181 }
182
183 # returns file type specific metadata
184 sub metacontent {
185   my ($file, %opts) = @_;
186   
187   my $cfg = delete $opts{cfg}
188     or confess "Missing cfg parameter";
189
190   my $name = delete $opts{name}
191     or confess "Missing name parameter";
192
193   my $handler = $file->handler($cfg);
194   return $handler->metacontent($file, $name);
195 }
196
197 sub apply_storage {
198   my ($self, $cfg, $mgr, $storage) = @_;
199
200   defined $storage or $storage = 'local';
201
202   if ($storage ne $self->storage) {
203     if ($self->storage ne "local") {
204       $mgr->unstore($self->filename, $self->storage);
205       $self->set_storage("local");
206     }
207     if ($storage ne "local") {
208       my $src = $mgr->store($self->filename, $storage, $self);
209         if ($src) {
210           $self->{src} = $src;
211           $self->{storage} = $storage;
212         }
213     }
214     $self->save;
215   }
216 }
217
218 =item metanames
219
220 returns the names of each metadatum defined for the file.
221
222 =cut
223
224 sub metanames {
225   my ($self) = @_;
226
227   require BSE::TB::ArticleFileMetas;
228   return BSE::TB::ArticleFileMetas->getColumnBy
229     (
230      "name",
231      [ file_id => $self->id ],
232     );
233 }
234
235 =item metainfo
236
237 Returns all but the value for metadata defined for the file.
238
239 =cut
240
241 sub metainfo {
242   my ($self) = @_;
243
244   require BSE::TB::ArticleFileMetas;
245   my @cols = grep $_ ne "value", BSE::TB::ArticleFileMeta->columns;
246   return BSE::TB::ArticleFileMetas->getColumnsBy
247     (
248      \@cols,
249      [ file_id => $self->id ],
250     );
251 }
252
253 sub metafields {
254   my ($self, $cfg) = @_;
255
256   my %metanames = map { $_ => 1 } $self->metanames;
257
258   my @fields = grep $metanames{$_->name} || $_->cond($self), BSE::TB::ArticleFiles->all_metametadata($cfg);
259
260   my $handler = $self->handler($cfg);
261
262   my @handler_fields = map BSE::FileMetaMeta->new(%$_, ro => 1, cfg => $cfg), $handler->metametadata;
263
264   return ( @fields, @handler_fields );
265 }
266
267 sub user_orders_for {
268   my ($self, $user) = @_;
269
270   require BSE::TB::Orders;
271   return BSE::TB::Orders->getSpecial(fileOrdersByUser => $self->id, $user->id);
272 }
273
274 sub downloadable_by {
275   my ($self, $user, $error) = @_;
276
277   $self->forSale
278     or return 1;
279
280   unless ($user) {
281     $$error = 'nouser';
282     return;
283   }
284
285   my @orders = $self->user_orders_for($user);
286   unless (@orders) {
287     $$error = 'noorder';
288     return;
289   }
290
291   if (BSE::TB::ArticleFiles->downloads_must_be_paid) {
292     @orders = grep $_->paidFor, @orders;
293     unless (@orders) {
294       $$error = 'unpaid';
295       return;
296     }
297   }
298
299   if (BSE::TB::ArticleFiles->downloads_must_be_filled) {
300     @orders = grep $_->filled, @orders;
301     unless (@orders) {
302       $$error = 'unfilled';
303       return;
304     }
305   }
306
307   return 1;
308 }
309
310 sub update {
311   my ($self, %opts) = @_;
312
313   my $actor = $opts{_actor}
314     or confess "Missing _actor parameter";
315
316   my $warnings = $opts{_warnings}
317     or confess "Missing _warnings parameter";
318
319   my $cfg = BSE::Cfg->single;
320   my $file_dir = BSE::TB::ArticleFiles->download_path($cfg);
321   my $old_storage = $self->storage;
322   my $delete_file;
323   if ($opts{filename} || $opts{file}) {
324     my $src_filename = delete $opts{filename};
325     my $filename;
326     if ($src_filename) {
327       if ($src_filename =~ /^\Q$file_dir\E/) {
328         # created in the right place, use it
329         $filename = $src_filename;
330       }
331       else {
332         open my $in_fh, "<", $src_filename
333           or die "Cannot open $src_filename: $!\n";
334         binmode $in_fh;
335
336         require DevHelp::FileUpload;
337         my $msg;
338         ($filename) = DevHelp::FileUpload->
339           make_fh_copy($in_fh, $file_dir, $opts{displayName}, \$msg)
340             or die "$msg\n";
341       }
342     }
343     elsif ($opts{file}) {
344       my $file = delete $opts{file};
345       require DevHelp::FileUpload;
346       my $msg;
347       ($filename) = DevHelp::FileUpload->
348         make_fh_copy($file, $file_dir, $opts{displayName}, \$msg)
349           or die "$msg\n";
350     }
351
352     my $fullpath = $file_dir . '/' . $filename;
353     $self->set_filename($filename);
354     $self->set_sizeInBytes(-s $fullpath);
355     $self->setDisplayName($opts{displayName});
356
357     unless ($opts{contentType}) {
358       require BSE::Util::ContentType;
359       $self->set_contentType(BSE::Util::ContentType::content_type($cfg, $opts{displayName}));
360     }
361
362     $self->set_handler($cfg);
363   }
364
365   my $type = delete $opts{contentType};
366   if (defined $type) {
367     $self->set_contentType($type);
368   }
369
370   for my $field (qw(displayName description forSale download requireUser notes hide_from_list category)) {
371     my $value = delete $opts{$field};
372     if (defined $value) {
373       my $method = "set_$field";
374       $self->$method($value);
375     }
376   }
377
378   my $name = $opts{name};
379   if (defined $name && $name =~ /\S/) {
380     $name =~ /^\w+$/
381       or die "name must be a single word\n";
382     my ($other) = BSE::TB::ArticleFiles->getBy(articleId => $self->id,
383                                                name => $name);
384     $other && $other->id != $self->id
385       and die "Duplicate file name (identifier)\n";
386
387     $self->set_name($name);
388   }
389
390   $self->save;
391
392   my $mgr = BSE::TB::ArticleFiles->file_manager($cfg);
393   if ($delete_file) {
394     if ($old_storage ne "local") {
395       $mgr->unstore($delete_file);
396     }
397     unlink "$file_dir/$delete_file";
398
399     $old_storage = "local";
400   }
401
402   my $storage = delete $opts{storage} || '';
403
404   my $new_storage;
405   eval {
406     $new_storage = 
407       $mgr->select_store($self->filename, $storage, $self);
408     if ($old_storage ne $new_storage) {
409       # handles both new images (which sets storage to local) and changing
410       # the storage for old images
411       my $src = $mgr->store($self->filename, $new_storage, $self);
412       $self->set_src($src);
413       $self->set_storage($new_storage);
414       $self->save;
415     }
416     1;
417   } or do {
418     my $msg = $@;
419     chomp $msg;
420     require BSE::TB::AuditLog;
421     BSE::TB::AuditLog->log
422       (
423        component => "admin:edit:saveimage",
424        level => "warning",
425        object => $self,
426        actor => $actor,
427        msg => "Error saving file to storage $new_storage: $msg",
428       );
429     push @$warnings, "msg:bse/admin/edit/file/save/savetostore:$msg";
430   };
431
432   if ($self->storage ne $old_storage && $old_storage ne "local") {
433     eval {
434       $mgr->unstore($self->filename, $old_storage);
435       1;
436     } or do {
437       my $msg = $@;
438       chomp $msg;
439       require BSE::TB::AuditLog;
440       BSE::TB::AuditLog->log
441         (
442          component => "admin:edit:savefile",
443          level => "warning",
444          object => $self,
445          actor => $actor,
446          msg => "Error saving file to storage $new_storage: $msg",
447         );
448       push @$warnings, "msg:bse/admin/edit/file/save/delfromstore:$msg";
449     };
450   }
451 }
452
453 sub meta_owner_type {
454   'bse_file';
455 }
456
457 1;