]>
Commit | Line | Data |
---|---|---|
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 |