6 our $VERSION = "1.001";
12 match => qr/^\s*[+-]?(?:\d+(?:\.\d+)|\.\d+)(?:[eE][+-]?\d+)?\s*\z/,
13 error => '$n must be a number',
20 string => "dh_one_line",
22 enum => "meta_enum", # generated
39 $opts{cfg} && $opts{cfg}->can("entry")
40 or confess "Missing or invalid cfg parameter";
42 or confess "Missing name parameter";
43 $opts{name} =~ /^[a-z]\w*$/i
44 or confess "Invalid metadata name parameter";
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;
51 $opts{title} ||= $name;
53 if ($opts{type} eq "enum") {
55 unless (ref $opts{values}) {
56 $opts{values} = [ split /;/, $opts{values} ];
59 or confess "$opts{name} has enum type but no values";
62 confess "$opts{name} has enum type but no values";
66 unless (ref $opts{labels}) {
67 $opts{labels} = [ split /;/, $opts{labels} ];
70 or confess "$opts{name} has enum type but no labels";
73 $opts{labels} = $opts{values};
77 ref $opts{rules} or $opts{rules} = [ split /[,;]/, $opts{rules} ];
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}: $@";
85 $opts{cond} = sub { 1 };
91 sub name { $_[0]{name} }
93 sub type { $_[0]{type} }
95 sub title { $_[0]{title} }
97 sub rules { @{$_[0]{rules}} }
99 sub values { @{$_[0]{values}} }
101 sub labels { @{$_[0]{labels}} }
105 sub unit { $_[0]{unit} }
108 $_[0]{type} ne "image";
112 my ($self, $file) = @_;
114 return $self->{cond}->($file);
118 my ($self, %opts) = @_;
120 my $value = delete $opts{value};
122 or confess "value not supplied\n";
123 my $rerror = delete $opts{error}
124 or confess "error ref not supplied\n";
127 require DevHelp::Validate;
128 my @field_rules = $self->rules;
129 $rule_map{$self->type} && unshift @field_rules, $rule_map{$self->type};
138 rules => \@field_rules,
139 description => $self->title,
142 my %rules = %meta_rules;
143 if ($self->type eq "enum") {
146 match => "^(?:" . join("|", map quotemeta, $self->values) . ")\\z",
147 error => '$n must be one of ' . join(", ", $self->values),
151 my $val = DevHelp::Validate::Hash->new
156 section => $self->validation_section,
159 $val->validate(\%values, \%errors);
161 $$rerror = $errors{value};
171 if ($self->type eq 'image') {
172 return ( $self->data_name, $self->width_name, $self->height_name );
192 qw/title help rules ro values labels type data_name width_name height_name cond unit/;
196 my ($class, $req, $owner, $errors) = @_;
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};
214 if ($meta->is_text) {
215 my ($value) = $cgi->param($cgi_name);
216 if (defined $value &&
217 ($value =~ /\S/ || $current_meta{$meta->name})) {
219 if ($meta->validate(value => $value, error => \$error)) {
227 $errors->{$cgi_name} = $error;
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);
238 if ($width && $height) {
242 name => $meta->data_name,
244 content_type => "image/\L$type",
247 name => $meta->width_name,
251 name => $meta->height_name,
257 $errors->{$cgi_name} = $type;
264 return { meta => \@meta, delete => \@meta_delete };
268 my ($class, $owner, $meta) = @_;
270 for my $meta_delete (@{$meta->{meta}}, map $_->{name}, @{$meta->{delete}}) {
271 $owner->delete_meta_by_name($meta_delete->{name});
273 for my $meta (@{$meta->{meta}}) {
274 $owner->add_meta(%$meta, appdata => 1);