make default, delete and note supplied via a options parameter
[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
4029e8ab 6our $VERSION = "1.002";
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
123=item width
124
125Display width. May be ignored depending on C<type>.
126
127=cut
128
129sub width { $_[0]{width} }
130
131=item height
132
133Display height. May be ignored depending on C<type>.
134
135=cut
136
137sub height { $_[0]{height} }
138
139=item ro
140
141Whether this field is read-only.
142
143=cut
144
f5b7b326
TC
145sub ro { $_[0]{ro} }
146
4029e8ab
TC
147=item unit
148
149Unit of measurement of this field (for display only)
150
151=cut
152
f5b7b326
TC
153sub unit { $_[0]{unit} }
154
4029e8ab
TC
155=item is_text
156
157True if this is representable as text.
158
159=cut
160
f5b7b326
TC
161sub is_text {
162 $_[0]{type} ne "image";
163}
164
4029e8ab
TC
165=item cond
166
167True if the field should be prompted for if not present.
168
169=cut
170
f5b7b326
TC
171sub cond {
172 my ($self, $file) = @_;
173
174 return $self->{cond}->($file);
175}
176
4029e8ab
TC
177=item field
178
179Return a hash suitable as the validation parameter for the field (and
180for template field formatting).
181
182=cut
183
184sub 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
215The field name of the metadata.
216
217=cut
218
f5b7b326
TC
219sub 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";
4029e8ab 227 my $section = $self->validation_section;
f5b7b326
TC
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},
4029e8ab 259 section => $section,
f5b7b326
TC
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
4029e8ab
TC
271=item name
272
273The field name of the metadata.
274
275=cut
276
f5b7b326
TC
277sub 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
4029e8ab
TC
288=item data_name
289
290The field name of the metadata.
291
292=cut
293
f5b7b326
TC
294sub data_name {
295 $_[0]{data_name}
296}
297
4029e8ab
TC
298=item width_name
299
300Where width information is stored for this image
301
302=cut
303
f5b7b326
TC
304sub width_name {
305 $_[0]{width_name}
306}
307
4029e8ab
TC
308=item height_name
309
310Where height information is stored for this image.
311
312=cut
313
f5b7b326
TC
314sub height_name {
315 $_[0]{height_name}
316}
317
4029e8ab
TC
318=item display_name
319
320Where the original filename is stored for the image.
321
322=cut
323
324sub display_name {
325 $_[0]{display_name}
326}
327
328=head1 CLASS METHODS
329
330=over
331
332=item new
333
334=cut
335
336sub 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
f5b7b326 409sub keys {
4029e8ab 410 qw/title help rules ro values labels type data_name width_name height_name cond unit htmltype width height/;
f5b7b326
TC
411}
412
413sub 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 },
4029e8ab
TC
472 {
473 name => $meta->display_name,
474 value => "" . $im,
475 },
f5b7b326
TC
476 );
477 }
478 else {
479 $errors->{$cgi_name} = $type;
480 }
481 }
482 }
483 }
484 }
485
486 return { meta => \@meta, delete => \@meta_delete };
487}
488
489sub 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
4029e8ab
TC
502sub 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
f5b7b326 5241;
4029e8ab
TC
525
526=back
527
528=cut