032bb710311153db99152d1e05973979da2ce8fa
[bse.git] / site / cgi-bin / modules / BSE / FileMetaMeta.pm
1 package BSE::FileMetaMeta;
2 use strict;
3 use Carp qw(confess);
4
5 our $VERSION = "1.000";
6
7 my %meta_rules =
8   (
9    meta_real =>
10    {
11     match => qr/^\s*[+-]?(?:\d+(?:\.\d+)|\.\d+)(?:[eE][+-]?\d+)?\s*\z/,
12     error => '$n must be a number',
13    },
14   );
15
16 my %rule_map =
17   (
18    integer => "integer",
19    string => "dh_one_line",
20    real => "meta_real",
21    enum => "meta_enum", # generated
22   );
23
24 sub new {
25   my $class = shift;
26   my %opts = 
27     (
28      rules => '',
29      ro => 0,
30      values => [],
31      cond => "1",
32      type => "string",
33      unit => '',
34      help => '',
35      @_
36     );
37
38   $opts{cfg} && $opts{cfg}->can("entry")
39     or confess "Missing or invalid cfg parameter";
40   $opts{name}
41     or confess "Missing name parameter";
42   $opts{name} =~ /^[a-z]\w*$/i
43     or confess "Invalid metadata name parameter";
44
45   my $name = $opts{name};
46   for my $subkey (qw/data width height/) {
47     my $key = $subkey . "_name";
48     defined $opts{$key} or $opts{$key} = $name . "_" . $subkey;
49   }
50   $opts{title} ||= $name;
51
52   if ($opts{type} eq "enum") {
53     if ($opts{values}) {
54       unless (ref $opts{values}) {
55         $opts{values} = [ split /;/, $opts{values} ];
56       }
57       @{$opts{values}}
58         or confess "$opts{name} has enum type but no values";
59     }
60     else {
61       confess "$opts{name} has enum type but no values";
62     }
63
64     if ($opts{labels}) {
65       unless (ref $opts{labels}) {
66         $opts{labels} = [ split /;/, $opts{labels} ];
67       }
68       @{$opts{labels}}
69         or confess "$opts{name} has enum type but no labels";
70     }
71     else {
72       $opts{labels} = $opts{values};
73     }
74   }
75
76   ref $opts{rules} or $opts{rules} = [ split /[,;]/, $opts{rules} ];
77
78   if ($opts{cond}) {
79     my $code = $opts{cond};
80     $opts{cond} = eval 'sub { my $file = shift; ' . $code . ' }'
81       or die "Cannot compile condition code <$code> for $opts{name}: $@";
82   }
83   else {
84     $opts{cond} = sub { 1 };
85   }
86
87   bless \%opts, $class;
88 }
89
90 sub name { $_[0]{name} }
91
92 sub type { $_[0]{type} }
93
94 sub title { $_[0]{title} }
95
96 sub rules { @{$_[0]{rules}} }
97
98 sub values { @{$_[0]{values}} }
99
100 sub labels { @{$_[0]{labels}} }
101
102 sub ro { $_[0]{ro} }
103
104 sub unit { $_[0]{unit} }
105
106 sub is_text {
107   $_[0]{type} ne "image";
108 }
109
110 sub cond {
111   my ($self, $file) = @_;
112
113   return $self->{cond}->($file);
114 }
115
116 sub validate {
117   my ($self, %opts) = @_;
118
119   my $value = delete $opts{value};
120   defined $value
121     or confess "value not supplied\n";
122   my $rerror = delete $opts{error}
123     or confess "error ref not supplied\n";
124
125   # kind of clumsy
126   require DevHelp::Validate;
127   my @field_rules = $self->rules;
128   $rule_map{$self->type} && unshift @field_rules, $rule_map{$self->type};
129   my %values =
130     (
131      value => $value
132     );
133   my %fields =
134     (
135      value =>
136      {
137       rules => \@field_rules,
138       description => $self->title,
139      },
140     );
141   my %rules = %meta_rules;
142   if ($self->type eq "enum") {
143     $rules{meta_enum} =
144       {
145        match => "^(?:" . join("|", map quotemeta, $self->values) . ")\\z",
146        error => '$n must be one of ' . join(", ", $self->values),
147       };
148   }
149
150   my $val = DevHelp::Validate::Hash->new
151     (
152      fields => \%fields,
153      rules => \%rules,
154      cfg => $self->{cfg},
155      section => "file metadata validation",
156     );
157   my %errors;
158   $val->validate(\%values, \%errors);
159   if (keys %errors) {
160     $$rerror = $errors{value};
161     return;
162   }
163
164   return 1;
165 }
166
167 sub metanames {
168   my ($self) = @_;
169
170   if ($self->type eq 'image') {
171     return ( $self->data_name, $self->width_name, $self->height_name );
172   }
173   else {
174     return $self->name;
175   }
176 }
177
178 sub data_name {
179   $_[0]{data_name}
180 }
181
182 sub width_name {
183   $_[0]{width_name}
184 }
185
186 sub height_name {
187   $_[0]{height_name}
188 }
189
190 sub keys {
191   qw/title help rules ro values labels type data_name width_name height_name cond unit/;
192 }
193
194 1;