allow fieldtype to be configure to set "type" in the fields
[bse.git] / site / cgi-bin / modules / BSE / MetaMeta.pm
CommitLineData
f5b7b326
TC
1package BSE::MetaMeta;
2use strict;
3use Carp qw(confess);
4use Image::Size;
5
da301b75 6our $VERSION = "1.003";
f5b7b326 7
4029e8ab
TC
8=head1 NAME
9
10BSE::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
23my %meta_rules;
f5b7b326
TC
24
25my %rule_map =
26 (
4029e8ab 27 image => "image",
f5b7b326
TC
28 integer => "integer",
29 string => "dh_one_line",
4029e8ab 30 real => "real",
f5b7b326
TC
31 enum => "meta_enum", # generated
32 );
33
4029e8ab
TC
34my %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 );
f5b7b326 66
4029e8ab 67=item name
f5b7b326 68
4029e8ab 69The field name of the metadata.
f5b7b326 70
4029e8ab 71=cut
f5b7b326 72
4029e8ab 73sub name { $_[0]{name} }
f5b7b326 74
4029e8ab 75=item type
f5b7b326 76
4029e8ab 77The type of the metadata.
f5b7b326 78
4029e8ab 79=cut
f5b7b326
TC
80
81sub type { $_[0]{type} }
82
4029e8ab
TC
83=item title
84
85The display name of the metadata.
86
87=cut
88
f5b7b326
TC
89sub title { $_[0]{title} }
90
4029e8ab
TC
91=item rules
92
93The validation rules for the metadata.
94
95=cut
96
f5b7b326
TC
97sub rules { @{$_[0]{rules}} }
98
4029e8ab
TC
99=item values
100
101The permitted values for the metadata for enum types.
102
103=cut
104
f5b7b326
TC
105sub values { @{$_[0]{values}} }
106
4029e8ab
TC
107=item labels
108
109The display labels as a list.
110
111=cut
112
f5b7b326
TC
113sub labels { @{$_[0]{labels}} }
114
4029e8ab
TC
115=item htmltype
116
117How to display this field. May be ignored depending on C<type>.
118
119=cut
120
121sub htmltype { $_[0]{htmltype} }
122
da301b75
TC
123=item fieldtype
124
125How to parse this field. May be ignored depending on type.
126
127=cut
128
129sub fieldtype { $_[0]{fieldtype} }
130
4029e8ab
TC
131=item width
132
133Display width. May be ignored depending on C<type>.
134
135=cut
136
137sub width { $_[0]{width} }
138
139=item height
140
141Display height. May be ignored depending on C<type>.
142
143=cut
144
145sub height { $_[0]{height} }
146
147=item ro
148
149Whether this field is read-only.
150
151=cut
152
f5b7b326
TC
153sub ro { $_[0]{ro} }
154
4029e8ab
TC
155=item unit
156
157Unit of measurement of this field (for display only)
158
159=cut
160
f5b7b326
TC
161sub unit { $_[0]{unit} }
162
4029e8ab
TC
163=item is_text
164
165True if this is representable as text.
166
167=cut
168
f5b7b326
TC
169sub is_text {
170 $_[0]{type} ne "image";
171}
172
4029e8ab
TC
173=item cond
174
175True if the field should be prompted for if not present.
176
177=cut
178
f5b7b326
TC
179sub cond {
180 my ($self, $file) = @_;
181
182 return $self->{cond}->($file);
183}
184
4029e8ab
TC
185=item field
186
187Return a hash suitable as the validation parameter for the field (and
188for template field formatting).
189
190=cut
191
192sub field {
193 my ($self) = @_;
194
195 my %field =
196 (
4029e8ab
TC
197 description => scalar $self->title,
198 units => scalar $self->unit,
199 rules => scalar $self->rules,
da301b75 200 rawtype => scalar $self->type,
4029e8ab 201 htmltype => scalar $self->htmltype,
da301b75
TC
202 type => scalar $self->fieldtype,
203 width => scalar $self->width,
204 height => scalar $self->height,
4029e8ab 205 );
da301b75
TC
206 my $defs = $field_defs{$self->type};
207 for my $key (keys %$defs) {
208 defined $field{$key} or $field{$key} = $defs->{$key};
209 }
4029e8ab
TC
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 }
da301b75 223 my %fields = ( $self->name => \%field );
4029e8ab 224
da301b75
TC
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};
4029e8ab
TC
231}
232
233=item name
234
235The field name of the metadata.
236
237=cut
238
f5b7b326
TC
239sub 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";
4029e8ab 247 my $section = $self->validation_section;
f5b7b326
TC
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},
4029e8ab 279 section => $section,
f5b7b326
TC
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
4029e8ab
TC
291=item name
292
293The field name of the metadata.
294
295=cut
296
f5b7b326
TC
297sub 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
4029e8ab
TC
308=item data_name
309
310The field name of the metadata.
311
312=cut
313
f5b7b326
TC
314sub data_name {
315 $_[0]{data_name}
316}
317
4029e8ab
TC
318=item width_name
319
320Where width information is stored for this image
321
322=cut
323
f5b7b326
TC
324sub width_name {
325 $_[0]{width_name}
326}
327
4029e8ab
TC
328=item height_name
329
330Where height information is stored for this image.
331
332=cut
333
f5b7b326
TC
334sub height_name {
335 $_[0]{height_name}
336}
337
4029e8ab
TC
338=item display_name
339
340Where the original filename is stored for the image.
341
342=cut
343
344sub display_name {
345 $_[0]{display_name}
346}
347
348=head1 CLASS METHODS
349
350=over
351
352=item new
353
354=cut
355
356sub 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 => '',
da301b75 367 fieldtype => "",
4029e8ab
TC
368 @_
369 );
370
da301b75
TC
371
372
4029e8ab
TC
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
f5b7b326 430sub keys {
da301b75 431 qw/title help rules ro values labels type data_name width_name height_name cond unit htmltype width height fieldtype/;
f5b7b326
TC
432}
433
434sub 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 },
4029e8ab
TC
493 {
494 name => $meta->display_name,
495 value => "" . $im,
496 },
f5b7b326
TC
497 );
498 }
499 else {
500 $errors->{$cgi_name} = $type;
501 }
502 }
503 }
504 }
505 }
506
507 return { meta => \@meta, delete => \@meta_delete };
508}
509
510sub 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
4029e8ab
TC
523sub 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
f5b7b326 5451;
4029e8ab
TC
546
547=back
548
549=cut