546139eada986f2c57edd16d1b987d8b6fa36d89
[bse.git] / site / cgi-bin / modules / BSE / MetaMeta.pm
1 package BSE::MetaMeta;
2 use strict;
3 use Carp qw(confess);
4 use Image::Size;
5
6 our $VERSION = "1.002";
7
8 =head1 NAME
9
10 BSE::MetaMeta - information about metadata.
11
12 =head1 SYNOPSIS
13
14   my @metainfo = $class->all_metametadata;
15   ...
16
17 =head1 INSTANCE METHODS
18
19 =over
20
21 =cut
22
23 my %meta_rules;
24
25 my %rule_map =
26   (
27    image => "image",
28    integer => "integer",
29    string => "dh_one_line",
30    real => "real",
31    enum => "meta_enum", # generated
32   );
33
34 my %field_defs =
35   (
36    image =>
37    {
38     htmltype => "file",
39    },
40    string =>
41    {
42     htmltype => "text",
43     width => 60,
44    },
45    text =>
46    {
47     htmltype => "textarea",
48     width => 60,
49     height => 20,
50    },
51    integer =>
52    {
53     htmltype => "text",
54     width => 8,
55    },
56    real =>
57    {
58     htmltype => "text",
59     width => 10,
60    },
61    enum =>
62    {
63     htmltype => "select",
64    },
65   );
66
67 =item name
68
69 The field name of the metadata.
70
71 =cut
72
73 sub name { $_[0]{name} }
74
75 =item type
76
77 The type of the metadata.
78
79 =cut
80
81 sub type { $_[0]{type} }
82
83 =item title
84
85 The display name of the metadata.
86
87 =cut
88
89 sub title { $_[0]{title} }
90
91 =item rules
92
93 The validation rules for the metadata.
94
95 =cut
96
97 sub rules { @{$_[0]{rules}} }
98
99 =item values
100
101 The permitted values for the metadata for enum types.
102
103 =cut
104
105 sub values { @{$_[0]{values}} }
106
107 =item labels
108
109 The display labels as a list.
110
111 =cut
112
113 sub labels { @{$_[0]{labels}} }
114
115 =item htmltype
116
117 How to display this field.  May be ignored depending on C<type>.
118
119 =cut
120
121 sub htmltype { $_[0]{htmltype} }
122
123 =item width
124
125 Display width.  May be ignored depending on C<type>.
126
127 =cut
128
129 sub width { $_[0]{width} }
130
131 =item height
132
133 Display height.  May be ignored depending on C<type>.
134
135 =cut
136
137 sub height { $_[0]{height} }
138
139 =item ro
140
141 Whether this field is read-only.
142
143 =cut
144
145 sub ro { $_[0]{ro} }
146
147 =item unit
148
149 Unit of measurement of this field (for display only)
150
151 =cut
152
153 sub unit { $_[0]{unit} }
154
155 =item is_text
156
157 True if this is representable as text.
158
159 =cut
160
161 sub is_text {
162   $_[0]{type} ne "image";
163 }
164
165 =item cond
166
167 True if the field should be prompted for if not present.
168
169 =cut
170
171 sub cond {
172   my ($self, $file) = @_;
173
174   return $self->{cond}->($file);
175 }
176
177 =item field
178
179 Return a hash suitable as the validation parameter for the field (and
180 for template field formatting).
181
182 =cut
183
184 sub field {
185   my ($self) = @_;
186
187   my %field =
188     (
189      %{$field_defs{$self->type}},
190      description => scalar $self->title,
191      units => scalar $self->unit,
192      rules => scalar $self->rules,
193      type => scalar $self->type,
194      htmltype => scalar $self->htmltype,
195     );
196   if ($self->type =~ /^(?:multi)?enum$/) {
197     my $values = [ $self->values ];
198     my $labels = [ $self->labels ];
199     my @values = map
200       +{ id => $values->[$_], label => $labels->[$_] },
201         0 .. $#$values;
202     $field{select} =
203       {
204        id => "id",
205        label => "label",
206        values => \@values,
207       };
208   }
209
210   return \%field;
211 }
212
213 =item name
214
215 The field name of the metadata.
216
217 =cut
218
219 sub validate {
220   my ($self, %opts) = @_;
221
222   my $value = delete $opts{value};
223   defined $value
224     or confess "value not supplied\n";
225   my $rerror = delete $opts{error}
226     or confess "error ref not supplied\n";
227   my $section = $self->validation_section;
228
229   # kind of clumsy
230   require DevHelp::Validate;
231   my @field_rules = $self->rules;
232   $rule_map{$self->type} && unshift @field_rules, $rule_map{$self->type};
233   my %values =
234     (
235      value => $value
236     );
237   my %fields =
238     (
239      value =>
240      {
241       rules => \@field_rules,
242       description => $self->title,
243      },
244     );
245   my %rules = %meta_rules;
246   if ($self->type eq "enum") {
247     $rules{meta_enum} =
248       {
249        match => "^(?:" . join("|", map quotemeta, $self->values) . ")\\z",
250        error => '$n must be one of ' . join(", ", $self->values),
251       };
252   }
253
254   my $val = DevHelp::Validate::Hash->new
255     (
256      fields => \%fields,
257      rules => \%rules,
258      cfg => $self->{cfg},
259      section => $section,
260     );
261   my %errors;
262   $val->validate(\%values, \%errors);
263   if (keys %errors) {
264     $$rerror = $errors{value};
265     return;
266   }
267
268   return 1;
269 }
270
271 =item name
272
273 The field name of the metadata.
274
275 =cut
276
277 sub metanames {
278   my ($self) = @_;
279
280   if ($self->type eq 'image') {
281     return ( $self->data_name, $self->width_name, $self->height_name );
282   }
283   else {
284     return $self->name;
285   }
286 }
287
288 =item data_name
289
290 The field name of the metadata.
291
292 =cut
293
294 sub data_name {
295   $_[0]{data_name}
296 }
297
298 =item width_name
299
300 Where width information is stored for this image
301
302 =cut
303
304 sub width_name {
305   $_[0]{width_name}
306 }
307
308 =item height_name
309
310 Where height information is stored for this image.
311
312 =cut
313
314 sub height_name {
315   $_[0]{height_name}
316 }
317
318 =item display_name
319
320 Where the original filename is stored for the image.
321
322 =cut
323
324 sub display_name {
325   $_[0]{display_name}
326 }
327
328 =head1 CLASS METHODS
329
330 =over
331
332 =item new
333
334 =cut
335
336 sub new {
337   my $class = shift;
338   my %opts = 
339     (
340      rules => '',
341      ro => 0,
342      values => [],
343      cond => "1",
344      type => "string",
345      unit => '',
346      help => '',
347      width => 60,
348      height => 40,
349      @_
350     );
351
352   $opts{cfg} && $opts{cfg}->can("entry")
353     or confess "Missing or invalid cfg parameter";
354   $opts{name}
355     or confess "Missing name parameter";
356   $opts{name} =~ /^[A-Za-z_][A-Za-z0-9_-]*$/
357     or confess "Invalid metadata name parameter";
358
359   $field_defs{$opts{type}} 
360     or confess "Unknown metadata type '$opts{type}' for field '$opts{name}'";
361
362   my $name = $opts{name};
363   for my $subkey (qw/data width height display/) {
364     my $key = $subkey . "_name";
365     defined $opts{$key} or $opts{$key} = $name . "_" . $subkey;
366   }
367   $opts{title} ||= $name;
368
369   if ($opts{type} =~ /^(?:multi)?enum/) {
370     if ($opts{values}) {
371       unless (ref $opts{values}) {
372         $opts{values} = [ split /;/, $opts{values} ];
373       }
374       @{$opts{values}}
375         or confess "$opts{name} has enum type but no values";
376     }
377     else {
378       confess "$opts{name} has enum type but no values";
379     }
380
381     if ($opts{labels}) {
382       unless (ref $opts{labels}) {
383         $opts{labels} = [ split /;/, $opts{labels} ];
384       }
385       @{$opts{labels}}
386         or confess "$opts{name} has enum type but no labels";
387     }
388     else {
389       $opts{labels} = $opts{values};
390     }
391   }
392
393   $opts{htmltype} ||= $field_defs{$opts{type}}{htmltype};
394
395   ref $opts{rules} or $opts{rules} = [ split /[,;]/, $opts{rules} ];
396
397   if ($opts{cond}) {
398     my $code = $opts{cond};
399     $opts{cond} = eval 'sub { my $file = shift; my $obj = $file; ' . $code . ' }'
400       or die "Cannot compile condition code <$code> for $opts{name}: $@";
401   }
402   else {
403     $opts{cond} = sub { 1 };
404   }
405
406   bless \%opts, $class;
407 }
408
409 sub keys {
410   qw/title help rules ro values labels type data_name width_name height_name cond unit htmltype width height/;
411 }
412
413 sub retrieve {
414   my ($class, $req, $owner, $errors) = @_;
415
416   my @meta;
417   my @meta_delete;
418   my $cgi = $req->cgi;
419   my @metafields = grep !$_->ro, $owner->metafields($req->cfg);
420   my %current_meta = map { $_ => 1 } $owner->metanames;
421   for my $meta (@metafields) {
422     my $name = $meta->name;
423     my $cgi_name = "meta_$name";
424     if ($cgi->param("delete_$cgi_name")) {
425       for my $metaname ($meta->metanames) {
426         push @meta_delete, $metaname
427           if $current_meta{$metaname};
428       }
429     }
430     else {
431       my $new;
432       if ($meta->is_text) {
433         my ($value) = $cgi->param($cgi_name);
434         if (defined $value && 
435             ($value =~ /\S/ || $current_meta{$meta->name})) {
436           my $error;
437           if ($meta->validate(value => $value, error => \$error)) {
438             push @meta,
439               {
440                name => $name,
441                value => $value,
442               };
443           }
444           else {
445             $errors->{$cgi_name} = $error;
446           }
447         }
448       }
449       else {
450         my $im = $cgi->param($cgi_name);
451         my $up = $cgi->upload($cgi_name);
452         if (defined $im && $up) {
453           my $data = do { local $/; <$up> };
454           my ($width, $height, $type) = imgsize(\$data);
455
456           if ($width && $height) {
457             push @meta,
458               (
459                {
460                 name => $meta->data_name,
461                 value => $data,
462                 content_type => "image/\L$type",
463                },
464                {
465                 name => $meta->width_name,
466                 value => $width,
467                },
468                {
469                 name => $meta->height_name,
470                 value => $height,
471                },
472                {
473                 name => $meta->display_name,
474                 value => "" . $im,
475                },
476               );
477           }
478           else {
479             $errors->{$cgi_name} = $type;
480           }
481         }
482       }
483     }
484   }
485
486   return { meta => \@meta, delete => \@meta_delete };
487 }
488
489 sub save {
490   my ($class, $owner, $meta) = @_;
491
492   for my $meta_delete (@{$meta->{meta}}, map $_->{name}, @{$meta->{delete}}) {
493     $owner->delete_meta_by_name($meta_delete->{name});
494   }
495   for my $meta (@{$meta->{meta}}) {
496     $owner->add_meta(%$meta, appdata => 1);
497   }
498
499   1;
500 }
501
502 sub all_metametadata {
503   my ($class, $cfg) = @_;
504
505   $cfg ||= BSE::Cfg->new;
506
507   my @metafields;
508   my @keys = $cfg->orderCS($class->fields_section);
509   for my $name (@keys) {
510     my %opts = ( name => $name );
511     my $section = $class->name_section($name);
512     for my $key ($class->keys) {
513       my $value = $cfg->entry($section, $key);
514       if (defined $value) {
515         $opts{$key} = $value;
516       }
517     }
518     push @metafields, $class->new(%opts, cfg => $cfg);
519   }
520
521   return @metafields;
522 }
523
524 1;
525
526 =back
527
528 =cut