don't crash when the default in .define is not initialized on .call
[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.012";
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 sub metafields {
219   my ($self, $cfg) = @_;
220
221   $cfg ||= BSE::Cfg->single;
222
223   my %metanames = map { $_ => 1 } $self->metanames;
224
225   require BSE::FileMetaMeta;
226   my @fields = grep $metanames{$_->name} || $_->cond($self), BSE::FileMetaMeta->all_metametadata($cfg);
227
228   my $handler = $self->handler($cfg);
229
230   my @handler_fields = map BSE::FileMetaMeta->new(%$_, ro => 1, cfg => $cfg), $handler->metametadata;
231
232   return ( @fields, @handler_fields );
233 }
234
235 sub user_orders_for {
236   my ($self, $user) = @_;
237
238   require BSE::TB::Orders;
239   return BSE::TB::Orders->getSpecial(fileOrdersByUser => $self->id, $user->id);
240 }
241
242 sub downloadable_by {
243   my ($self, $user, $error) = @_;
244
245   $self->forSale
246     or return 1;
247
248   unless ($user) {
249     $$error = 'nouser';
250     return;
251   }
252
253   my @orders = $self->user_orders_for($user);
254   unless (@orders) {
255     $$error = 'noorder';
256     return;
257   }
258
259   if (BSE::TB::ArticleFiles->downloads_must_be_paid) {
260     @orders = grep $_->paidFor, @orders;
261     unless (@orders) {
262       $$error = 'unpaid';
263       return;
264     }
265   }
266
267   if (BSE::TB::ArticleFiles->downloads_must_be_filled) {
268     @orders = grep $_->filled, @orders;
269     unless (@orders) {
270       $$error = 'unfilled';
271       return;
272     }
273   }
274
275   return 1;
276 }
277
278 sub update {
279   my ($self, %opts) = @_;
280
281   my $actor = $opts{_actor}
282     or confess "Missing _actor parameter";
283
284   my $warnings = $opts{_warnings}
285     or confess "Missing _warnings parameter";
286
287   my $cfg = BSE::Cfg->single;
288   my $file_dir = BSE::TB::ArticleFiles->download_path($cfg);
289   my $old_storage = $self->storage;
290   my $delete_file;
291   if ($opts{filename} || $opts{file}) {
292     my $src_filename = delete $opts{filename};
293     my $filename;
294     if ($src_filename) {
295       if ($src_filename =~ /^\Q$file_dir\E/) {
296         # created in the right place, use it
297         $filename = $src_filename;
298       }
299       else {
300         open my $in_fh, "<", $src_filename
301           or die "Cannot open $src_filename: $!\n";
302         binmode $in_fh;
303
304         require DevHelp::FileUpload;
305         my $msg;
306         ($filename) = DevHelp::FileUpload->
307           make_fh_copy($in_fh, $file_dir, $opts{displayName}, \$msg)
308             or die "$msg\n";
309       }
310     }
311     elsif ($opts{file}) {
312       my $file = delete $opts{file};
313       require DevHelp::FileUpload;
314       my $msg;
315       ($filename) = DevHelp::FileUpload->
316         make_fh_copy($file, $file_dir, $opts{displayName}, \$msg)
317           or die "$msg\n";
318     }
319
320     my $fullpath = $file_dir . '/' . $filename;
321     $self->set_filename($filename);
322     $self->set_sizeInBytes(-s $fullpath);
323     $self->setDisplayName($opts{displayName});
324
325     unless ($opts{contentType}) {
326       require BSE::Util::ContentType;
327       $self->set_contentType(BSE::Util::ContentType::content_type($cfg, $opts{displayName}));
328     }
329
330     $self->set_handler($cfg);
331   }
332
333   my $type = delete $opts{contentType};
334   if (defined $type) {
335     $self->set_contentType($type);
336   }
337
338   for my $field (qw(displayName description forSale download requireUser notes hide_from_list category)) {
339     my $value = delete $opts{$field};
340     if (defined $value) {
341       my $method = "set_$field";
342       $self->$method($value);
343     }
344   }
345
346   my $name = $opts{name};
347   if (defined $name && $name =~ /\S/) {
348     $name =~ /^\w+$/
349       or die "name must be a single word\n";
350     my ($other) = BSE::TB::ArticleFiles->getBy(articleId => $self->id,
351                                                name => $name);
352     $other && $other->id != $self->id
353       and die "Duplicate file name (identifier)\n";
354
355     $self->set_name($name);
356   }
357
358   $self->save;
359
360   my $mgr = BSE::TB::ArticleFiles->file_manager($cfg);
361   if ($delete_file) {
362     if ($old_storage ne "local") {
363       $mgr->unstore($delete_file);
364     }
365     unlink "$file_dir/$delete_file";
366
367     $old_storage = "local";
368   }
369
370   my $storage = delete $opts{storage} || '';
371
372   my $new_storage;
373   eval {
374     $new_storage = 
375       $mgr->select_store($self->filename, $storage, $self);
376     if ($old_storage ne $new_storage) {
377       # handles both new images (which sets storage to local) and changing
378       # the storage for old images
379       my $src = $mgr->store($self->filename, $new_storage, $self);
380       $self->set_src($src);
381       $self->set_storage($new_storage);
382       $self->save;
383     }
384     1;
385   } or do {
386     my $msg = $@;
387     chomp $msg;
388     require BSE::TB::AuditLog;
389     BSE::TB::AuditLog->log
390       (
391        component => "admin:edit:saveimage",
392        level => "warning",
393        object => $self,
394        actor => $actor,
395        msg => "Error saving file to storage $new_storage: $msg",
396       );
397     push @$warnings, "msg:bse/admin/edit/file/save/savetostore:$msg";
398   };
399
400   if ($self->storage ne $old_storage && $old_storage ne "local") {
401     eval {
402       $mgr->unstore($self->filename, $old_storage);
403       1;
404     } or do {
405       my $msg = $@;
406       chomp $msg;
407       require BSE::TB::AuditLog;
408       BSE::TB::AuditLog->log
409         (
410          component => "admin:edit:savefile",
411          level => "warning",
412          object => $self,
413          actor => $actor,
414          msg => "Error saving file to storage $new_storage: $msg",
415         );
416       push @$warnings, "msg:bse/admin/edit/file/save/delfromstore:$msg";
417     };
418   }
419 }
420
421 sub meta_owner_type {
422   'bse_file';
423 }
424
425 sub meta_meta_cfg_section {
426   "global file metadata";
427 }
428
429 sub meta_meta_cfg_prefix {
430   "file metadata";
431 }
432
433 sub restricted_method {
434   my ($self, $name) = @_;
435
436   return $self->Squirrel::Row::restricted_method($name)
437     || $self->BSE::MetaOwnerBase::restricted_method($name);
438 }
439
440 1;