allow fieldtype to be configure to set "type" in the fields
[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.003";
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 fieldtype
124
125 How to parse this field.  May be ignored depending on type.
126
127 =cut
128
129 sub fieldtype { $_[0]{fieldtype} }
130
131 =item width
132
133 Display width.  May be ignored depending on C<type>.
134
135 =cut
136
137 sub width { $_[0]{width} }
138
139 =item height
140
141 Display height.  May be ignored depending on C<type>.
142
143 =cut
144
145 sub height { $_[0]{height} }
146
147 =item ro
148
149 Whether this field is read-only.
150
151 =cut
152
153 sub ro { $_[0]{ro} }
154
155 =item unit
156
157 Unit of measurement of this field (for display only)
158
159 =cut
160
161 sub unit { $_[0]{unit} }
162
163 =item is_text
164
165 True if this is representable as text.
166
167 =cut
168
169 sub is_text {
170   $_[0]{type} ne "image";
171 }
172
173 =item cond
174
175 True if the field should be prompted for if not present.
176
177 =cut
178
179 sub cond {
180   my ($self, $file) = @_;
181
182   return $self->{cond}->($file);
183 }
184
185 =item field
186
187 Return a hash suitable as the validation parameter for the field (and
188 for template field formatting).
189
190 =cut
191
192 sub field {
193   my ($self) = @_;
194
195   my %field =
196     (
197      description => scalar $self->title,
198      units => scalar $self->unit,
199      rules => scalar $self->rules,
200      rawtype => scalar $self->type,
201      htmltype => scalar $self->htmltype,
202      type => scalar $self->fieldtype,
203      width => scalar $self->width,
204      height => scalar $self->height,
205     );
206   my $defs = $field_defs{$self->type};
207   for my $key (keys %$defs) {
208     defined $field{$key} or $field{$key} = $defs->{$key};
209   }
210   if ($self->type =~ /^(?:multi)?enum$/) {
211     my $values = [ $self->values ];
212     my $labels = [ $self->labels ];
213     my @values = map
214       +{ id => $values->[$_], label => $labels->[$_] },
215         0 .. $#$values;
216     $field{select} =
217       {
218        id => "id",
219        label => "label",
220        values => \@values,
221       };
222   }
223   my %fields = ( $self->name => \%field );
224
225   require BSE::Validate;
226   my $configured = 
227     BSE::Validate::bse_configure_fields({ $self->name => \%fields }, BSE::Cfg->single,
228                                         $self->validation_section);
229
230   return $fields{$self->name};
231 }
232
233 =item name
234
235 The field name of the metadata.
236
237 =cut
238
239 sub validate {
240   my ($self, %opts) = @_;
241
242   my $value = delete $opts{value};
243   defined $value
244     or confess "value not supplied\n";
245   my $rerror = delete $opts{error}
246     or confess "error ref not supplied\n";
247   my $section = $self->validation_section;
248
249   # kind of clumsy
250   require DevHelp::Validate;
251   my @field_rules = $self->rules;
252   $rule_map{$self->type} && unshift @field_rules, $rule_map{$self->type};
253   my %values =
254     (
255      value => $value
256     );
257   my %fields =
258     (
259      value =>
260      {
261       rules => \@field_rules,
262       description => $self->title,
263      },
264     );
265   my %rules = %meta_rules;
266   if ($self->type eq "enum") {
267     $rules{meta_enum} =
268       {
269        match => "^(?:" . join("|", map quotemeta, $self->values) . ")\\z",
270        error => '$n must be one of ' . join(", ", $self->values),
271       };
272   }
273
274   my $val = DevHelp::Validate::Hash->new
275     (
276      fields => \%fields,
277      rules => \%rules,
278      cfg => $self->{cfg},
279      section => $section,
280     );
281   my %errors;
282   $val->validate(\%values, \%errors);
283   if (keys %errors) {
284     $$rerror = $errors{value};
285     return;
286   }
287
288   return 1;
289 }
290
291 =item name
292
293 The field name of the metadata.
294
295 =cut
296
297 sub metanames {
298   my ($self) = @_;
299
300   if ($self->type eq 'image') {
301     return ( $self->data_name, $self->width_name, $self->height_name );
302   }
303   else {
304     return $self->name;
305   }
306 }
307
308 =item data_name
309
310 The field name of the metadata.
311
312 =cut
313
314 sub data_name {
315   $_[0]{data_name}
316 }
317
318 =item width_name
319
320 Where width information is stored for this image
321
322 =cut
323
324 sub width_name {
325   $_[0]{width_name}
326 }
327
328 =item height_name
329
330 Where height information is stored for this image.
331
332 =cut
333
334 sub height_name {
335   $_[0]{height_name}
336 }
337
338 =item display_name
339
340 Where the original filename is stored for the image.
341
342 =cut
343
344 sub display_name {
345   $_[0]{display_name}
346 }
347
348 =head1 CLASS METHODS
349
350 =over
351
352 =item new
353
354 =cut
355
356 sub new {
357   my $class = shift;
358   my %opts = 
359     (
360      rules => '',
361      ro => 0,
362      values => [],
363      cond => "1",
364      type => "string",
365      unit => '',
366      help => '',
367      fieldtype => "",
368      @_
369     );
370
371   
372
373   $opts{cfg} && $opts{cfg}->can("entry")
374     or confess "Missing or invalid cfg parameter";
375   $opts{name}
376     or confess "Missing name parameter";
377   $opts{name} =~ /^[A-Za-z_][A-Za-z0-9_-]*$/
378     or confess "Invalid metadata name parameter";
379
380   $field_defs{$opts{type}} 
381     or confess "Unknown metadata type '$opts{type}' for field '$opts{name}'";
382
383   my $name = $opts{name};
384   for my $subkey (qw/data width height display/) {
385     my $key = $subkey . "_name";
386     defined $opts{$key} or $opts{$key} = $name . "_" . $subkey;
387   }
388   $opts{title} ||= $name;
389
390   if ($opts{type} =~ /^(?:multi)?enum/) {
391     if ($opts{values}) {
392       unless (ref $opts{values}) {
393         $opts{values} = [ split /;/, $opts{values} ];
394       }
395       @{$opts{values}}
396         or confess "$opts{name} has enum type but no values";
397     }
398     else {
399       confess "$opts{name} has enum type but no values";
400     }
401
402     if ($opts{labels}) {
403       unless (ref $opts{labels}) {
404         $opts{labels} = [ split /;/, $opts{labels} ];
405       }
406       @{$opts{labels}}
407         or confess "$opts{name} has enum type but no labels";
408     }
409     else {
410       $opts{labels} = $opts{values};
411     }
412   }
413
414   $opts{htmltype} ||= $field_defs{$opts{type}}{htmltype};
415
416   ref $opts{rules} or $opts{rules} = [ split /[,;]/, $opts{rules} ];
417
418   if ($opts{cond}) {
419     my $code = $opts{cond};
420     $opts{cond} = eval 'sub { my $file = shift; my $obj = $file; ' . $code . ' }'
421       or die "Cannot compile condition code <$code> for $opts{name}: $@";
422   }
423   else {
424     $opts{cond} = sub { 1 };
425   }
426
427   bless \%opts, $class;
428 }
429
430 sub keys {
431   qw/title help rules ro values labels type data_name width_name height_name cond unit htmltype width height fieldtype/;
432 }
433
434 sub retrieve {
435   my ($class, $req, $owner, $errors) = @_;
436
437   my @meta;
438   my @meta_delete;
439   my $cgi = $req->cgi;
440   my @metafields = grep !$_->ro, $owner->metafields($req->cfg);
441   my %current_meta = map { $_ => 1 } $owner->metanames;
442   for my $meta (@metafields) {
443     my $name = $meta->name;
444     my $cgi_name = "meta_$name";
445     if ($cgi->param("delete_$cgi_name")) {
446       for my $metaname ($meta->metanames) {
447         push @meta_delete, $metaname
448           if $current_meta{$metaname};
449       }
450     }
451     else {
452       my $new;
453       if ($meta->is_text) {
454         my ($value) = $cgi->param($cgi_name);
455         if (defined $value && 
456             ($value =~ /\S/ || $current_meta{$meta->name})) {
457           my $error;
458           if ($meta->validate(value => $value, error => \$error)) {
459             push @meta,
460               {
461                name => $name,
462                value => $value,
463               };
464           }
465           else {
466             $errors->{$cgi_name} = $error;
467           }
468         }
469       }
470       else {
471         my $im = $cgi->param($cgi_name);
472         my $up = $cgi->upload($cgi_name);
473         if (defined $im && $up) {
474           my $data = do { local $/; <$up> };
475           my ($width, $height, $type) = imgsize(\$data);
476
477           if ($width && $height) {
478             push @meta,
479               (
480                {
481                 name => $meta->data_name,
482                 value => $data,
483                 content_type => "image/\L$type",
484                },
485                {
486                 name => $meta->width_name,
487                 value => $width,
488                },
489                {
490                 name => $meta->height_name,
491                 value => $height,
492                },
493                {
494                 name => $meta->display_name,
495                 value => "" . $im,
496                },
497               );
498           }
499           else {
500             $errors->{$cgi_name} = $type;
501           }
502         }
503       }
504     }
505   }
506
507   return { meta => \@meta, delete => \@meta_delete };
508 }
509
510 sub save {
511   my ($class, $owner, $meta) = @_;
512
513   for my $meta_delete (@{$meta->{meta}}, map $_->{name}, @{$meta->{delete}}) {
514     $owner->delete_meta_by_name($meta_delete->{name});
515   }
516   for my $meta (@{$meta->{meta}}) {
517     $owner->add_meta(%$meta, appdata => 1);
518   }
519
520   1;
521 }
522
523 sub all_metametadata {
524   my ($class, $cfg) = @_;
525
526   $cfg ||= BSE::Cfg->new;
527
528   my @metafields;
529   my @keys = $cfg->orderCS($class->fields_section);
530   for my $name (@keys) {
531     my %opts = ( name => $name );
532     my $section = $class->name_section($name);
533     for my $key ($class->keys) {
534       my $value = $cfg->entry($section, $key);
535       if (defined $value) {
536         $opts{$key} = $value;
537       }
538     }
539     push @metafields, $class->new(%opts, cfg => $cfg);
540   }
541
542   return @metafields;
543 }
544
545 1;
546
547 =back
548
549 =cut