f90df2e3de5511cbc142c6c674d563fd3707342a
[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.001";
7
8 my %meta_rules =
9   (
10    meta_real =>
11    {
12     match => qr/^\s*[+-]?(?:\d+(?:\.\d+)|\.\d+)(?:[eE][+-]?\d+)?\s*\z/,
13     error => '$n must be a number',
14    },
15   );
16
17 my %rule_map =
18   (
19    integer => "integer",
20    string => "dh_one_line",
21    real => "meta_real",
22    enum => "meta_enum", # generated
23   );
24
25 sub new {
26   my $class = shift;
27   my %opts = 
28     (
29      rules => '',
30      ro => 0,
31      values => [],
32      cond => "1",
33      type => "string",
34      unit => '',
35      help => '',
36      @_
37     );
38
39   $opts{cfg} && $opts{cfg}->can("entry")
40     or confess "Missing or invalid cfg parameter";
41   $opts{name}
42     or confess "Missing name parameter";
43   $opts{name} =~ /^[a-z]\w*$/i
44     or confess "Invalid metadata name parameter";
45
46   my $name = $opts{name};
47   for my $subkey (qw/data width height/) {
48     my $key = $subkey . "_name";
49     defined $opts{$key} or $opts{$key} = $name . "_" . $subkey;
50   }
51   $opts{title} ||= $name;
52
53   if ($opts{type} eq "enum") {
54     if ($opts{values}) {
55       unless (ref $opts{values}) {
56         $opts{values} = [ split /;/, $opts{values} ];
57       }
58       @{$opts{values}}
59         or confess "$opts{name} has enum type but no values";
60     }
61     else {
62       confess "$opts{name} has enum type but no values";
63     }
64
65     if ($opts{labels}) {
66       unless (ref $opts{labels}) {
67         $opts{labels} = [ split /;/, $opts{labels} ];
68       }
69       @{$opts{labels}}
70         or confess "$opts{name} has enum type but no labels";
71     }
72     else {
73       $opts{labels} = $opts{values};
74     }
75   }
76
77   ref $opts{rules} or $opts{rules} = [ split /[,;]/, $opts{rules} ];
78
79   if ($opts{cond}) {
80     my $code = $opts{cond};
81     $opts{cond} = eval 'sub { my $file = shift; ' . $code . ' }'
82       or die "Cannot compile condition code <$code> for $opts{name}: $@";
83   }
84   else {
85     $opts{cond} = sub { 1 };
86   }
87
88   bless \%opts, $class;
89 }
90
91 sub name { $_[0]{name} }
92
93 sub type { $_[0]{type} }
94
95 sub title { $_[0]{title} }
96
97 sub rules { @{$_[0]{rules}} }
98
99 sub values { @{$_[0]{values}} }
100
101 sub labels { @{$_[0]{labels}} }
102
103 sub ro { $_[0]{ro} }
104
105 sub unit { $_[0]{unit} }
106
107 sub is_text {
108   $_[0]{type} ne "image";
109 }
110
111 sub cond {
112   my ($self, $file) = @_;
113
114   return $self->{cond}->($file);
115 }
116
117 sub validate {
118   my ($self, %opts) = @_;
119
120   my $value = delete $opts{value};
121   defined $value
122     or confess "value not supplied\n";
123   my $rerror = delete $opts{error}
124     or confess "error ref not supplied\n";
125
126   # kind of clumsy
127   require DevHelp::Validate;
128   my @field_rules = $self->rules;
129   $rule_map{$self->type} && unshift @field_rules, $rule_map{$self->type};
130   my %values =
131     (
132      value => $value
133     );
134   my %fields =
135     (
136      value =>
137      {
138       rules => \@field_rules,
139       description => $self->title,
140      },
141     );
142   my %rules = %meta_rules;
143   if ($self->type eq "enum") {
144     $rules{meta_enum} =
145       {
146        match => "^(?:" . join("|", map quotemeta, $self->values) . ")\\z",
147        error => '$n must be one of ' . join(", ", $self->values),
148       };
149   }
150
151   my $val = DevHelp::Validate::Hash->new
152     (
153      fields => \%fields,
154      rules => \%rules,
155      cfg => $self->{cfg},
156      section => $self->validation_section,
157     );
158   my %errors;
159   $val->validate(\%values, \%errors);
160   if (keys %errors) {
161     $$rerror = $errors{value};
162     return;
163   }
164
165   return 1;
166 }
167
168 sub metanames {
169   my ($self) = @_;
170
171   if ($self->type eq 'image') {
172     return ( $self->data_name, $self->width_name, $self->height_name );
173   }
174   else {
175     return $self->name;
176   }
177 }
178
179 sub data_name {
180   $_[0]{data_name}
181 }
182
183 sub width_name {
184   $_[0]{width_name}
185 }
186
187 sub height_name {
188   $_[0]{height_name}
189 }
190
191 sub keys {
192   qw/title help rules ro values labels type data_name width_name height_name cond unit/;
193 }
194
195 sub retrieve {
196   my ($class, $req, $owner, $errors) = @_;
197
198   my @meta;
199   my @meta_delete;
200   my $cgi = $req->cgi;
201   my @metafields = grep !$_->ro, $owner->metafields($req->cfg);
202   my %current_meta = map { $_ => 1 } $owner->metanames;
203   for my $meta (@metafields) {
204     my $name = $meta->name;
205     my $cgi_name = "meta_$name";
206     if ($cgi->param("delete_$cgi_name")) {
207       for my $metaname ($meta->metanames) {
208         push @meta_delete, $metaname
209           if $current_meta{$metaname};
210       }
211     }
212     else {
213       my $new;
214       if ($meta->is_text) {
215         my ($value) = $cgi->param($cgi_name);
216         if (defined $value && 
217             ($value =~ /\S/ || $current_meta{$meta->name})) {
218           my $error;
219           if ($meta->validate(value => $value, error => \$error)) {
220             push @meta,
221               {
222                name => $name,
223                value => $value,
224               };
225           }
226           else {
227             $errors->{$cgi_name} = $error;
228           }
229         }
230       }
231       else {
232         my $im = $cgi->param($cgi_name);
233         my $up = $cgi->upload($cgi_name);
234         if (defined $im && $up) {
235           my $data = do { local $/; <$up> };
236           my ($width, $height, $type) = imgsize(\$data);
237
238           if ($width && $height) {
239             push @meta,
240               (
241                {
242                 name => $meta->data_name,
243                 value => $data,
244                 content_type => "image/\L$type",
245                },
246                {
247                 name => $meta->width_name,
248                 value => $width,
249                },
250                {
251                 name => $meta->height_name,
252                 value => $height,
253                },
254               );
255           }
256           else {
257             $errors->{$cgi_name} = $type;
258           }
259         }
260       }
261     }
262   }
263
264   return { meta => \@meta, delete => \@meta_delete };
265 }
266
267 sub save {
268   my ($class, $owner, $meta) = @_;
269
270   for my $meta_delete (@{$meta->{meta}}, map $_->{name}, @{$meta->{delete}}) {
271     $owner->delete_meta_by_name($meta_delete->{name});
272   }
273   for my $meta (@{$meta->{meta}}) {
274     $owner->add_meta(%$meta, appdata => 1);
275   }
276
277   1;
278 }
279
280 1;