more metadata generalization and modification
[bse.git] / site / cgi-bin / modules / DevHelp / Validate.pm
CommitLineData
0ec4ac8a
TC
1package DevHelp::Validate;
2use strict;
3require Exporter;
4use vars qw(@EXPORT_OK @ISA);
a5e3fc4b 5@EXPORT_OK = qw(dh_validate dh_validate_hash dh_fieldnames dh_configure_fields);
0ec4ac8a 6@ISA = qw(Exporter);
ae1bd061 7use Carp qw(confess);
0ec4ac8a 8
4029e8ab 9our $VERSION = "1.008";
4e0d6e9e
TC
10
11my $re_real =
12 qr/
13 (
14 [-+]? # optional sign
15 (?:
16 [0-9]+(?:\.[0-9]*)? # either 9 with optional decimal digits
17 |
18 \.[0-9]+ # or . with required digits
19 )
20 (?:[eE][-+]?[0-9]+)? # optional exponent
21 )
22 /x;
cb7fd78d 23
0ec4ac8a
TC
24my %built_ins =
25 (
26 email =>
27 {
74a3bc31 28 match => qr/^[^\s\@][^\@]*\@[\w.-]+\.\w+$/,
0ec4ac8a
TC
29 error => '$n is not a valid email address',
30 },
31 phone =>
32 {
33 match => qr/\d(?:\D*\d){3}/,
34 error => '$n is not a valid phone number',
35 },
36 postcode =>
37 {
38 match => qr/\d(?:\D*\d){3}/,
39 error => '$n is not a valid post code',
40 },
9074efa2
TC
41 # international post code
42 dh_int_postcode =>
43 {
fbfbc417 44 match => qr/[\w-](?:[^\w-]*[\w-]){3}/,
9074efa2
TC
45 error => '$n is not a valid post code',
46 },
0ec4ac8a
TC
47 url =>
48 {
49 match => qr!^\w+://[\w-]+(?:\.[\w-]+)+(?::\d+)?!,
50 error => '$n is not a valid URL',
51 },
52 weburl =>
53 {
54 match => qr!^https?://[\w-]+(?:\.[\w-]+)+(?::\d+)?!,
55 error => '$n is not a valid URL, it must start with http:// or https://',
56 },
57 newbieweburl =>
58 {
59 match => qr!^(?:https?://)?[\w-]+(?:\.[\w-]+)+(?::\d+)?!,
60 error => '$n is not a valid URL',
61 },
62 confirm =>
63 {
64 confirm=>'password',
65 },
66 newconfirm =>
67 {
68 newconfirm=>'password',
69 },
70 required =>
71 {
72 required => 1,
73 },
74 abn =>
75 {
76 match => qr/\d(?:\D*\d){7}/,
77 error => '$n is not a valid ABN',
78 },
79 creditcardnumber =>
80 {
81 match => qr/^\D*\d(?:\D*\d){11,15}\D*$/,
82 error => '$n is not a valid credit card number',
83 },
84 creditcardexpiry =>
85 {
86 ccexpiry => 1,
87 },
41e7c841
TC
88 creditcardexpirysingle =>
89 {
90 ccexpirysingle => 1,
91 },
92 creditcardcvv =>
93 {
94 match => qr/^(\d){3,4}$/,
95 error => '$n is the 3 or 4 digit code on the back of your card',
96 },
0ec4ac8a
TC
97 miaa =>
98 {
99 match => qr/^\s*\d{1,6}\s*$/,
100 error => 'Not a valid MIAA membership number',
101 },
102 decimal =>
103 {
104 match => qr/^\s*(?:\d+(?:\.\d*)?|\.\d+)\s*$/,
105 error => 'Not a valid number',
106 },
107 money =>
108 {
109 match => qr/^\s*(?:\d+(?:\.\d\d)?|\.\d\d)\s*$/,
110 error => 'Not a valid money amount',
111 },
112 date =>
113 {
114 date => 1,
115 },
116 birthdate =>
117 {
118 date => 1,
119 maxdate => '+0y',
120 maxdatemsg => 'Your $n must be in the past',
121 },
122 adultbirthdate =>
123 {
124 date => 1,
125 maxdate => '-10y',
126 maxdatemsg => 'You must be at least 10 years old...',
127 mindate => '-100y',
128 },
129 futuredate =>
130 {
131 date => 1,
132 mindate => '-1d',
133 mindatemsg => 'The date entered must be in the future',
134 },
7dd6ebae
TC
135 pastdate =>
136 {
137 date => 1,
138 maxdate => '+1d',
139 maxdatemsg => 'The date entered must be in the past',
140 },
f625a822
TC
141 time =>
142 {
143 time => 1,
144 },
59fca225
TC
145 integer =>
146 {
147 integer => 1,
148 },
0ec4ac8a
TC
149 natural =>
150 {
151 integer => '0-', # 0 or higher
152 },
153 positiveint =>
154 {
155 integer => '1-', # 1 or higher
156 },
829c9ed9
TC
157 dh_one_line =>
158 {
159 nomatch => qr/[\x0D\x0A]/,
160 error => '$n may only contain a single line',
16ac5598 161 },
4029e8ab
TC
162 real =>
163 {
164 real => 1,
165 },
16ac5598
TC
166 time =>
167 {
168 # we accept 24-hour time, or 12 hour with (a|p|am|pm)
169 match => qr!^(?: # first 24 hour time:
170 (?:[01]?\d|2[0-3]) # hour 0-23
171 [:.] # separator
172 [0-5]\d # minute
32696f84 173 (?:[:.][0-5]\d)? # optional seconds
16ac5598
TC
174 | # or 12 hour time:
175 (?:0?[1-9]|1[012]) # hour 1-12
176 (?:[:.] # optionally separator followed
32696f84
TC
177 [0-5]\d # by minutes
178 (?:[:.][0-5]\d)? # optionall by seconds
179 )?
16ac5598
TC
180 [ap]m? # followed by afternoon/morning
181 )$!ix,
182 error=>'Invalid time $n',
183 },
0ec4ac8a
TC
184 );
185
0b3db116
TC
186sub new {
187 my ($class, %opts) = @_;
0ec4ac8a 188
0b3db116 189 my $self = bless \%opts, $class;
0ec4ac8a 190
0b3db116
TC
191 # configure validation
192 my $fields = $self->{fields};
193 my $rules = $self->{rules} || {};
0ec4ac8a 194
0ec4ac8a 195 my %cfg_rules;
ae1bd061 196 _get_cfg_fields(\%cfg_rules, $self->{cfg}, $self->{section}, $fields, $opts{dbh})
0ec4ac8a
TC
197 if $self->{cfg} && $self->{section};
198
199 for my $rulename (keys %$rules) {
200 unless (exists $cfg_rules{rules}{$rulename}) {
201 $cfg_rules{rules}{$rulename} = $rules->{$rulename};
202 }
203 }
204 for my $rulename (keys %built_ins) {
205 unless (exists $cfg_rules{rules}{$rulename}) {
206 $cfg_rules{rules}{$rulename} = $built_ins{$rulename};
207 }
208 }
209
210 # merge the supplied fields into the config fields
211 my $cfg_fields = $cfg_rules{fields};
212 for my $field ( keys %$fields ) {
213 my $src = $fields->{$field};
214
215 my $dest = $cfg_fields->{$field} || {};
216
217 # the config overrides the software supplied fields
cd88fc15 218 for my $override (qw(description required required_error maxlength range_error mindatemsg maxdatemsg ne_error)) {
0ec4ac8a
TC
219 if (defined $src->{$override} && !defined $dest->{$override}) {
220 $dest->{$override} = $src->{$override};
221 }
222 }
223
cc53c774 224 # but we add rules and required_if
0ec4ac8a
TC
225 if ($dest->{rules}) {
226 my $rules = $src->{rules};
227
228 # make a copy of the rules array if it's supplied that way so
229 # we don't modify someone else's data
230 $rules = ref $rules ? [ @$rules ] : [ split /;/, $rules ];
231
232 push @$rules, split /;/, $dest->{rules};
4c390983
TC
233
234 $dest->{rules} = $rules;
0ec4ac8a
TC
235 }
236 elsif ($src->{rules}) {
237 $dest->{rules} = $src->{rules};
238 }
cc53c774
TC
239 if ($dest->{required_if}) {
240 $dest->{required_if} .= ";" . $src->{required_if} if $src->{required_if};
241 }
242 elsif ($src->{required_if}) {
243 $dest->{required_if} = $src->{required_if};
244 }
0ec4ac8a
TC
245
246 $cfg_fields->{$field} = $dest if keys %$dest;
247 }
0b3db116
TC
248
249 $self->{cfg_fields} = $cfg_fields;
250 $self->{cfg_rules} = $cfg_rules{rules};
251
252 return $self;
253}
254
255sub dh_validate {
256 my ($cgi, $errors, $validation, $cfg, $section) = @_;
257
1547b6e9
TC
258 return DevHelp::Validate::CGI->new
259 (
260 cfg => $cfg,
261 section => $section,
262 fields => $validation->{fields},
263 rules => $validation->{rules},
264 optional => $validation->{optional},
265 dbh => $validation->{dbh},
266 )
0b3db116
TC
267 ->validate($cgi, $errors);
268}
269
270sub dh_validate_hash {
271 my ($hash, $errors, $validation, $cfg, $section) = @_;
272
1547b6e9
TC
273 return DevHelp::Validate::Hash->new
274 (
275 cfg => $cfg,
276 section => $section,
277 fields => $validation->{fields},
278 rules => $validation->{rules},
279 optional=>$validation->{optional},
280 dbh => $validation->{dbh},
281 )
0b3db116
TC
282 ->validate($hash, $errors);
283}
284
285sub _validate {
286 my ($self, $errors) = @_;
287
288 my $cfg_fields = $self->{cfg_fields};
289 my $cfg_rules = $self->{cfg_rules};
290 my $optional = $self->{optional};
291
0ec4ac8a 292 for my $field ( keys %$cfg_fields ) {
0b3db116 293 $self->validate_field($field, $cfg_fields->{$field}, $cfg_rules,
0ec4ac8a
TC
294 $optional, $errors);
295 }
296
297 !keys %$errors;
298}
299
6258aadc
TC
300my @dow_tokens = qw(sun mon tue wed thu fri sat);
301my @dow_names = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
302my %dow_trans;
303@dow_trans{@dow_tokens} = @dow_names;
304
0ec4ac8a
TC
305sub validate_field {
306 my ($self, $field, $info, $rules, $optional, $errors) = @_;
307
308 my @data = $self->param($field);
309
310 my $required = $info->{required};
311 if (@data && $data[0] !~ /\S/ && $info->{required_if}) {
312 # field is required if any of the named fields are non-blank
313 for my $testfield (split /;/, $info->{required_if}) {
a41629b1
TC
314 my ($field_name, $field_value) = split /=/, $testfield;
315 my $testvalue = $self->param($field_name);
316 if (defined $testvalue &&
317 (defined $field_value && $testvalue eq $field_value
318 || !defined $field_value && $testvalue =~ /\S/)) {
0ec4ac8a
TC
319 ++$required;
320 last;
321 }
322 }
323 }
324
353a0885
TC
325 if (defined $info->{maxlength}) {
326 for my $testdata (@data) {
327 if (length $testdata > $info->{maxlength}) {
bab8c301
TC
328 $errors->{$field} = _make_error($field, $info, {},
329 q!$n too long!);
353a0885
TC
330 return;
331 }
332 }
333 }
334
0ec4ac8a
TC
335 my $rule_names = $info->{rules};
336 defined $rule_names or $rule_names = '';
337 $rule_names = [ split /;/, $rule_names ] unless ref $rule_names;
338
339 push @$rule_names, 'required' if $required;
340
341 @$rule_names or return;
342
343 RULE: for my $rule_name (@$rule_names) {
344 my $rule = $rules->{$rule_name};
345 unless ($rule) {
346 $rule = $self->_get_cfg_rule($rule_name);
347 if ($rule) {
348 $rules->{$rule_name} = $rule;
349 }
350 else {
351 print STDERR "** Unknown validation rule $rule_name for $field\n";
352 }
353 }
354 if (!$optional && $rule->{required} && !@data ) {
355 $errors->{$field} = _make_error($field, $info, $rule,
356 $info->{required_error} ||
357 $rule->{required_error} ||
358 '$n is a required field');
359 last RULE;
360 }
361 for my $data (@data) {
362 if ($rule->{required} && $data !~ /\S/) {
363 $errors->{$field} = _make_error($field, $info, $rule,
364 $info->{required_error} ||
365 $rule->{required_error} ||
366 '$n is a required field');
367 last RULE;
368 }
369 if ($rule->{newconfirm}) {
370 my $other = $self->param($rule->{newconfirm});
371 if ($other ne '' || $data ne '') {
372 if ($other ne $data) {
373 $errors->{$field} = _make_error($field, $info, $rule,
374 q!$n doesn't match the password!);
375 last RULE;
376 }
377 }
378 }
33b7f58c
TC
379 if (defined $rule->{nomatch}) {
380 my $match = $rule->{nomatch};
381 if ($data =~ /$match/) {
382 $errors->{$field} = _make_error($field, $info, $rule);
383 last RULE;
384 }
385 }
0ec4ac8a
TC
386 if ($data !~ /\S/ && !$rule->{required}) {
387 next RULE;
388 }
389 if ($rule->{match}) {
390 my $match = $rule->{match};
391 unless ($data =~ /$match/) {
392 $errors->{$field} = _make_error($field, $info, $rule);
393 last RULE;
0ec4ac8a
TC
394 }
395 }
396 if ($rule->{integer}) {
4e0d6e9e 397 unless ($data =~ /^\s*([-+]?\d+)\s*$/) {
0ec4ac8a
TC
398 $errors->{$field} = _make_error($field, $info, $rule,
399 '$n must be a whole number');
400 last RULE;
401 }
402 my $num = $1;
403 if (my ($from, $to) = $rule->{integer} =~ /^([+-]?\d+)-([+-]?\d+)$/) {
404 unless ($from <= $num and $num <= $to) {
405 $errors->{$field} = _make_error($field, $info, $rule,
406 $info->{range_error} ||
407 $rule->{range_error} ||
408 "\$n must be in the range $from to $to");
409 last RULE;
410 }
411 }
412 elsif (my ($from2) = $rule->{integer} =~ /^([+-]?\d+)-$/) {
413 unless ($from2 <= $num) {
414 $errors->{$field} = _make_error($field, $info, $rule,
415 $info->{range_error} ||
416 $rule->{range_error} ||
417 "\$n must be $from2 or higher");
418 last RULE;
419 }
420 }
421 }
422 if ($rule->{date}) {
423 unless ($data =~ m!^\s*(\d+)[-+/](\d+)[-+/](\d+)\s*$!) {
424 $errors->{$field} = _make_error($field, $info, $rule,
425 '$n must be a valid date');
426 last RULE;
427 }
428 my ($day, $month, $year) = ($1, $2, $3);
429 if ($day < 1 || $day > 31) {
430 $errors->{$field} = _make_error($field, $info, $rule,
431 '$n must be a valid date - day out of range');
432 last RULE;
433 }
434 if ($month < 1 || $month > 12) {
435 $errors->{$field} = _make_error($field, $info, $rule,
436 '$n must be a valid date - month out of range');
437 last RULE;
438 }
16ac5598
TC
439 require DevHelp::Date;
440 my $msg;
441 unless (($year, $month, $day) = DevHelp::Date::dh_parse_date($data, \$msg)) {
442 $errors->{$field} = $msg;
443 last RULE;
444 }
ae1bd061
TC
445 unless (DevHelp::Date::dh_valid_date($year, $month, $day)) {
446 $errors->{$field} = _make_error($field, $info, $rule,
447 '$n must be a valid date');
448 last RULE;
449 }
0ec4ac8a 450 if ($rule->{mindate} || $rule->{maxdate}) {
0ec4ac8a
TC
451 my $workdate = sprintf("%04d-%02d-%02d", $year, $month, $day);
452 if ($rule->{mindate}) {
453 my $mindate = DevHelp::Date::dh_parse_date_sql($rule->{mindate});
353a0885 454 if ($workdate lt $mindate) {
0ec4ac8a
TC
455 $errors->{$field} =
456 _make_error($field, $info, $rule,
457 $info->{mindatemsg} || $rule->{mindatemsg} || '$n is too early');
458 }
459 }
460 if (!$errors->{$field} && $rule->{maxdate}) {
461 my $maxdate = DevHelp::Date::dh_parse_date_sql($rule->{maxdate});
353a0885 462 if ($workdate gt $maxdate) {
0ec4ac8a
TC
463 $errors->{$field} =
464 _make_error($field, $info, $rule,
465 $info->{mindatemsg} || $rule->{maxdatemsg} || '$n is too late');
466 }
467 }
468 }
6258aadc
TC
469 if (defined $rule->{dow}) { # could be "0" for Sunday
470 my $dow = DevHelp::Date::dh_date_dow($year, $month, $day);
471 my ($dow_name) = $dow_tokens[$dow];
472 unless ($rule->{dow} =~ /\b($dow|$dow_name)\b/i) {
473 my @valid_dow = map {
474 ;$_ =~ /[0-7]/ ? $dow_names[$_] : $dow_trans{$_}
475 } split /,/, $rule->{dow};
476 my $valid_dow = @valid_dow > 1
477 ? "any of " . join(", ", @valid_dow)
478 : "a @valid_dow";
479 $errors->{$field} =
480 _make_error($field, $info, $rule,
481 $info->{dowmsg} || $rule->{dowmsg}
482 || ('$n must fall on ' . $valid_dow));
483 last RULE;
484 }
485 }
0ec4ac8a 486 }
f625a822
TC
487 if ($rule->{time}) {
488 require DevHelp::Date;
489 my $msg;
490 if (my ($hour, $min, $sec)
491 = DevHelp::Date::dh_parse_time($data, \$msg)) {
492 # nothing to do here yet, later it will allow limits
493 }
494 else {
495 $errors->{$field} =
496 _make_error($field, $info, $rule,
497 '$n is not a valid time of day');
498 last RULE;
499 }
500 }
0ec4ac8a
TC
501 if ($rule->{confirm}) {
502 my $other = $self->param($rule->{confirm});
503 unless ($other eq $data) {
504 $errors->{$field} = _make_error($field, $info, $rule,
505 q!$n doesn't match the password!);
506 last RULE;
507 }
508 }
cd88fc15
TC
509 if ($rule->{notequal}) {
510 for my $ne_field (split /,/, $rule->{notequal}) {
511 next if $ne_field eq $field;
512 my $other = $self->param($ne_field);
513 if ($other eq $data) {
514 $errors->{$field} = _make_error
515 (
516 $field, $info, $rule,
517 $info->{ne_error}
518 || $rule->{ne_error}
519 || "\$n may not be the same as $ne_field"
520 );
521 last RULE;
522 }
523 }
524 }
0ec4ac8a
TC
525 if ($rule->{ccexpiry}) {
526 (my $year_field = $field) =~ s/month/year/;
527
528 unless ($data =~ /^\s*\d+\s*$/) {
529 $errors->{$field} = _make_error($field, $info, $rule,
530 q!$n month isn't a number!);
531 last RULE;
532 }
533 my $year = $self->param($year_field);
534 unless (defined $year && $year =~ /\s*\d+\s*$/) {
535 $errors->{$field} = _make_error($field, $info, $rule,
536 q!$n year isn't a number!);
537 last RULE;
538 }
539 my ($now_year, $now_month) = (localtime)[5, 4];
540 $now_year += 1900;
541 ++$now_month;
542 if ($year < $now_year || $year == $now_year && $data < $now_month) {
543 $errors->{$field} = _make_error($field, $info, $rule,
544 q!$n is in the past, your card has expired!);
545 last RULE;
546 }
547 }
41e7c841
TC
548 if ($rule->{ccexpirysingle}) {
549 unless ($data =~ m!^\s*(\d+)\s*/\s*(\d+)+\s*$!) {
550 $errors->{$field} = _make_error($field, $info, $rule,
551 q!$n must be in MM/YY format!);
552 last RULE;
553 }
554 my ($month, $year) = ($1, $2);
555 $year += 2000;
556 if ($month < 1 || $month > 12) {
557 $errors->{$field} = _make_error($field, $info, $rule,
558 q!$n month must be between 1 and 12!);
559 last RULE;
560 }
561 my ($now_year, $now_month) = (localtime)[5, 4];
562 $now_year += 1900;
563 ++$now_month;
564 if ($year < $now_year || $year == $now_year && $month < $now_month) {
565 $errors->{$field} = _make_error($field, $info, $rule,
566 q!$n is in the past, your card has expired!);
567 last RULE;
568 }
569 }
4e0d6e9e
TC
570 if ($rule->{real}) {
571 unless ($data =~ /^\s*$re_real\s*$/) {
572 $errors->{$field} = _make_error($field, $info, $rule,
573 '$n must be a number');
574 last RULE;
575 }
576 my $num = $1;
577 if (my ($from, $to) = $rule->{real} =~ /^$re_real\s*-\s*$re_real$/) {
578 unless ($from <= $num and $num <= $to) {
579 $errors->{$field} = _make_error($field, $info, $rule,
580 $info->{range_error} ||
581 $rule->{range_error} ||
582 "\$n must be in the range $from to $to");
583 last RULE;
584 }
585 }
586 elsif (my ($from2) = $rule->{real} =~ /^\s*$re_real\s*-$/) {
587 unless ($from2 <= $num) {
588 $errors->{$field} = _make_error($field, $info, $rule,
589 $info->{range_error} ||
590 $rule->{range_error} ||
591 "\$n must be $from2 or higher");
592 last RULE;
593 }
594 }
595 }
193d1fd0
TC
596 if ($rule->{ref}) {
597 my $method = $rule->{method}
598 or confess "Missing method in ref rule $rule_name";
f625a822
TC
599 my $before = $rule->{before};
600 my @before = defined $before ? ( ref $before ? @$before : split /,/, $before ) : ();
601 my $after = $rule->{after};
602 my @after = defined $after ? ( ref $after ? @$after : split /,/, $after ) : ();
603 unless ($rule->{ref}->$method(@before, $data, @after)) {
193d1fd0
TC
604 $errors->{$field} = _make_error($field, $info, $rule, 'No such $n');
605 last RULE;
606 }
607 }
0ec4ac8a
TC
608 }
609 }
610}
611
612sub _make_error {
613 my ($field, $info, $rule, $message) = @_;
614
b812201d 615 $message = $rule->{error} || $message || 'Validation error on field $n';
0ec4ac8a
TC
616
617 my $name = $info->{description} || $field;
618 $message =~ s/\$n/$name/g;
619
620 return $message;
621}
622
ae1bd061
TC
623sub _get_cfg_values_sql {
624 my ($field_ref, $cfg, $field, $section, $dbh) = @_;
625
626 $dbh
627 or confess "Missing database handle for $section/${field}_values";
628 my $groups_sql = $cfg->entry($section, "${field}_values_group_sql");
629 my $values_sql = $cfg->entry($section, "${field}_values_sql");
630 my $empty_groups = $cfg->entry($section, "${field}_empty_groups");
631
632 my $values_sth = $dbh->prepare($values_sql)
633 or confess "Cannot prepare $values_sql: ", $dbh->errstr;
634 $values_sth->execute
635 or confess "Cannot execute $values_sql: ", $values_sth->errstr;
636 my @value_rows;
637 while (my $row = $values_sth->fetchrow_hashref) {
638 push @value_rows, +{ %$row };
639 }
640 $values_sth->finish;
641 if ($groups_sql) {
642 my $groups_sth = $dbh->prepare($groups_sql)
643 or confess "Cannot prepare $groups_sql: ", $dbh->errstr;
644 $groups_sth->execute
645 or confess "Cannot execute $groups_sql: ", $groups_sth->errstr;
646 my @group_rows;
647 while (my $row = $groups_sth->fetchrow_hashref) {
648 push @group_rows, +{ %$row };
649 }
650
651 if (@group_rows) {
652 my %values;
653 my %group_ids = map { $_->{id} => 1 } @group_rows;
654 my $bad_values;
655 my %group_values;
656
657 # collate the values
658 for my $value_row (@value_rows) {
659 unless (defined $value_row->{group_id}) {
660 ++$bad_values;
661 print STDERR "Row for $field missing group_id\n";
662 last;
663 }
664 unless ($group_ids{$value_row->{group_id}}) {
665 ++$bad_values;
666 print STDERR "Row for $field $value_row->{id} group id $value_row->{group_id} not in group list\n";
667 last;
668 }
669 push @{$group_values{$value_row->{group_id}}}, $value_row->{id};
670 }
671 unless ($bad_values) {
672 my @groups;
673 for my $group (@group_rows) {
674 my @value_ids;
675 @value_ids = @{$group_values{$group->{id}}}
676 if $group_values{$group->{id}};
677 if ($empty_groups || @value_ids) {
678 push @groups, [ $group->{label}, \@value_ids ];
679 }
680 }
681 if (@groups) {
682 $field_ref->{value_groups} = \@groups;
683 }
684 }
685 else {
686 # fall through and just list the values
687 print STDERR "Value rows included group ids which weren't returned in groups - not grouping\n";
688 }
689 }
690 else {
691 # fall through and just list the values
692 print STDERR "Group sql for $field provided returned no rows\n";
693 }
694 }
695
696 return map [ $_->{id}, $_->{label} ], @value_rows;
697}
698
699sub _get_cfg_groups {
700 my ($field_ref, $cfg, $field, $section) = @_;
701
702 my $groups = $cfg->entry($section, "${field}_groups")
703 or return;
704
705 my @groups;
706 for my $group_entry (split /;/, $groups) {
707 my ($label, $ids) = split /=/, $group_entry, 2;
708 push @groups, [ $label, [ split /,/, $ids ] ];
709 }
710 $field_ref->{value_groups} = \@groups;
711}
712
0ec4ac8a 713sub _get_cfg_fields {
ae1bd061 714 my ($rules, $cfg, $section, $field_hash, $dbh) = @_;
0ec4ac8a
TC
715
716 $rules->{rules} = {};
717 $rules->{fields} = {};
718
719 my $cfg_fields = $rules->{fields};
720
721 my $fields = $cfg->entry($section, 'fields', '');
722 my @names = ( split(/,/, $fields), keys %$field_hash );
59fca225
TC
723 my @extra_config;
724 push @extra_config, split /,/, $cfg->entry("form validation", "field_config", "");
725 push @extra_config, split /,/, $cfg->entry($section, "field_config", "");
0ec4ac8a
TC
726
727 for my $field (@names) {
ae1bd061 728 $cfg_fields->{$field} = {};
59fca225 729 for my $cfg_name (qw(required rules description required_error range_error mindatemsg maxdatemsg ne_error), @extra_config) {
0ec4ac8a
TC
730 my $value = $cfg->entry($section, "${field}_$cfg_name");
731 if (defined $value) {
732 $cfg_fields->{$field}{$cfg_name} = $value;
733 }
734 }
d44b5da9
TC
735
736 my $values = $cfg->entry($section, "${field}_values");
737 if (defined $values) {
738 my @values;
ae1bd061
TC
739 if ($values eq "-sql") {
740 @values = _get_cfg_values_sql($cfg_fields->{$field}, $cfg, $field, $section, $dbh);
741 }
742 elsif ($values =~ /;/) {
d44b5da9 743 for my $entry (split /;/, $values) {
cc53c774 744 if ($entry =~ /^([^=]*)=(.*)$/) {
d44b5da9
TC
745 push @values, [ $1, $2 ];
746 }
747 else {
748 push @values, [ $entry, $entry ];
749 }
750 }
ae1bd061 751 _get_cfg_groups($cfg_fields->{$field}, $cfg, $field, $section);
d44b5da9
TC
752 }
753 else {
cc53c774
TC
754 my $strip;
755 if ($values =~ s/:([^:]*)$//) {
756 $strip = $1;
757 }
d44b5da9
TC
758 my %entries = $cfg->entriesCS($values);
759 my @order = $cfg->orderCS($values);
760
761 my %seen;
762 # we only want the last value in the order
763 @order = reverse grep !$seen{$_}++, reverse @order;
764 @values = map [ $_, $entries{$_} ], @order;
cc53c774
TC
765 if ($strip) {
766 $_->[0] =~ s/^\Q$strip// for @values;
767 }
ae1bd061 768 _get_cfg_groups($cfg_fields->{$field}, $cfg, $field, $section);
d44b5da9
TC
769 }
770 $cfg_fields->{$field}{values} = \@values;
771 }
0ec4ac8a
TC
772 }
773}
774
a5e3fc4b 775sub dh_configure_fields {
ae1bd061 776 my ($fields, $cfg, $section, $dbh) = @_;
a5e3fc4b
TC
777
778 my %cfg_rules;
ae1bd061 779 _get_cfg_fields(\%cfg_rules, $cfg, $section, $fields, $dbh);
a5e3fc4b
TC
780
781 # **FIXME** duplicated code
782 my $cfg_fields = $cfg_rules{fields};
783 for my $field ( keys %$fields ) {
784 my $src = $fields->{$field};
785
786 my $dest = $cfg_fields->{$field} || {};
787
788 # the config overrides the software supplied fields
69793e10 789 for my $override (grep $_ ne "rules", keys %$src) {
a5e3fc4b
TC
790 if (defined $src->{$override} && !defined $dest->{$override}) {
791 $dest->{$override} = $src->{$override};
792 }
793 }
794
795 # but we add rules
796 if ($dest->{rules}) {
af01e4f6 797 my $rules = $src->{rules} || '';
a5e3fc4b
TC
798
799 # make a copy of the rules array if it's supplied that way so
800 # we don't modify someone else's data
801 $rules = ref $rules ? [ @$rules ] : [ split /;/, $rules ];
802
803 push @$rules, split /;/, $dest->{rules};
804 }
805 elsif ($src->{rules}) {
806 $dest->{rules} = $src->{rules};
807 }
808
809 $cfg_fields->{$field} = $dest if keys %$dest;
810 }
811
812 return $cfg_fields;
813}
814
0ec4ac8a
TC
815sub _get_cfg_rule {
816 my ($self, $rulename) = @_;
817
818 my %rule = $self->{cfg}->entries("Validation Rule $rulename");
819
820 keys %rule or return;
821
822 \%rule;
823}
824
825sub dh_fieldnames {
826 my ($cfg, $section, $fields) = @_;
827
828 # this needs to be obsoleted now that dh_validate() checks the config
829
830 for my $field (keys %$fields) {
831 my $desc = $cfg->entry($section, $field);
832 defined $desc and $fields->{$field}{description} = $desc;
833 }
834}
835
836package DevHelp::Validate::CGI;
837use vars qw(@ISA);
838@ISA = qw(DevHelp::Validate);
839
840sub param {
841 my ($self, $field) = @_;
842
843 $self->{cgi}->param($field);
844}
845
0b3db116
TC
846sub validate {
847 my ($self, $cgi, $errors) = @_;
848
849 $self->{cgi} = $cgi;
850
851 return $self->_validate($errors);
852}
853
0ec4ac8a
TC
854package DevHelp::Validate::Hash;
855use vars qw(@ISA);
856@ISA = qw(DevHelp::Validate);
857
858sub param {
859 my ($self, $field) = @_;
860
861 my $value = $self->{hash}{$field};
862
863 defined $value or return;
864
865 if (ref $value eq 'ARRAY') {
866 return @$value;
867 }
868
869 return $value;
870}
871
0b3db116
TC
872sub validate {
873 my ($self, $hash, $errors) = @_;
874
875 $self->{hash} = $hash;
876
877 return $self->_validate($errors);
878}
879
0ec4ac8a
TC
8801;
881
882__END__
883
884=head1 NAME
885
886DevHelp::Validate - handy configurable validation, I hope
887
888=head1 SYNOPSIS
889
890 use DevHelp::Validate qw(dh_validate);
891
892 dh_validate($cgi, \%errors, \%rules, $cfg)
893 or display_errors(..., \%errors);
894
895=head1 DESCRIPTION
896
f625a822
TC
897Performs simple validation of CGI or hash data.
898
0ec4ac8a
TC
899=head1 RULES PARAMETER
900
901The rules parameter is a hash with 2 keys:
902
903=over
904
905=item fields
906
907A hash of field names, for each of which the value is a hash.
908
909Each hash can have the following keys:
910
911=over
912
913=item rules
914
915A simple rule name, a ';' separated list of rule names or an array
916ref.
917
918=item description
919
920A short description of the field, for use in error messages.
921
922=back
923
924=item rules
925
926A hash of rules. See the rules description under L<CONFIGURED
f625a822 927VALIDATION>.
0ec4ac8a
TC
928
929=back
930
931=head1 CONFIGURED VALIDATION
932
933Rules can be configured in the database.
934
935For the specified section name, each key is a CGI field name.
936
937The values of those keys gives the name of a validation rule, a string
938id for internationlization of the field description and a default
939field description, separated by commas.
940
f625a822
TC
941Each validation rule name has a corresponding section,C<< [Validation
942Rule I<rule-name>] >>, which describes the rule. Rule names can also
943refer to built-in rules,
0ec4ac8a
TC
944
945Values in the validation rule section are:
946
947=over
948
949=item required
950
951If this is non-zero the field is required.
952
953=item match
954
955If present, this is used as a regular expression the field must match.
956
829c9ed9
TC
957=item nomatch
958
959If present, this is used as a regular expression the field must not
960match.
961
0ec4ac8a
TC
962=item error
963
964Message returned as the error if the field fails validation.
965
966=item integer
967
968If set to 1, simply ensures the value is an integer.
969
970If set to a range I<integer>-I<integer> then ensures the value is an
971integer in that range.
972
4e0d6e9e
TC
973=item real
974
975If set to 1, simply ensures the value is an real number.
976
977If set to a range C<< I<real> - I<real> >> then ensures the value is
978a real number in that range.
979
0ec4ac8a
TC
980=item date
981
982If set to 1, simply validates the value as a date.
983
cd88fc15
TC
984Set mindate to specify a minimum date for range validation. Uses
985mindatemsg from the field or rule for the error message.
986
987Set maxdate to specify a maximum date for range validation. Uses
988maxdatemsg from the field or rule for the error message.
989
6258aadc
TC
990Set C<dow> to a comma-separated list of number from 0 to 6, or 3
991letter day of week abbreviations to require the date be only on those
992days of week. Uses C<dowmsg> from the field or rule for the error
993message.
994
f625a822
TC
995=item time
996
997If true, validates that the value can be parsed by
998L<DevHelp::Date/dh_parse_time()>.
999
cd88fc15
TC
1000=item confirm
1001
1002Specify another field that the field must be equal to, intended for
1003password confirm validation.
1004
1005=item notequal
1006
1007A list of field names that may not be equal to the current field. If
1008the current field is in the list it is ignored, so you can use one
1009rule to compare several fields with each other. Uses ne_error from
1010the field, or ne_error from the rule for customizing the error
1011message.
1012
193d1fd0
TC
1013=item ref
1014
1015Requires that C<method> also be set.
1016
1017Calls the specified method on the object or class specified by C<ref>
1018with the value to check as a parameter. The value is considered value
1019if the result is true. This is intended for checking the existence of
1020objects in a collection.
1021
f625a822
TC
1022Optionally C<before> can be an array ref or comma-separated list of
1023parameters to supply before the value.
1024
1025Optionally C<after> can be an array ref or comma-separated list of
1026parameters to supply after the value.
1027
0ec4ac8a
TC
1028=back
1029
829c9ed9
TC
1030=head1 BUILT-IN RULES
1031
1032=over
1033
1034=item email
1035
1036=item phone
1037
1038=item postcode
1039
1040=item url
1041
1042Matches any valid url, including mailto:, ftp:, etc. No checking of
1043the scheme is done.
1044
1045=item weburl
1046
1047Matches any valid http or https url.
1048
1049=item newbieweburl
1050
1051Matches web URLs with or without "http://" or "https://".
1052
1053=item confirm
1054
1055Treats the given field as a confirmation field for a password field
1056"password".
1057
1058=item newconfirm
1059
1060Treats the given field as a confirmation field for an optional
1061password field "password".
1062
1063=item required
1064
1065The field is required. This should be used where the logic of the
1066code requires a field, since it cannot be overridden by the config
1067file.
1068
1069=item abn
1070
1071Valid Australian Business Number
1072
1073=item creditcardnumber
1074
1075Valid credit card number (no checksum checks are performed).
1076
1077=item creditcardexpiry
1078
1079Treats the field as the month part of a credit card expiry date, with
1080the year field being the field with the same name, but "month"
1081replaced with "year". The date of expiry is required to be in the
1082future.
1083
1084=item miaa
1085
1086Valid MIAA membership number.
1087
1088=item decimal
1089
1090Valid simple decimal number
1091
1092=item money
1093
1094Valid decimal number with 0 or 2 digits after the decimal point.
1095
1096=item date
1097
1098A valid date. Currently dates are limited to Australian format
1099dd/mm/yy or dd/mm/yyyy format dates.
1100
1101=item birthdate
1102
1103A valid date in the past.
1104
1105=item adultbirthdate
1106
1107A valid date at least 10 years in the past, at most 100 years in the
1108past.
1109
1110=item futuredate
1111
1112A valid date in the future.
1113
f625a822
TC
1114=item time
1115
1116Parses as a time as per dh_parse_time().
1117
59fca225
TC
1118=item integer
1119
1120Any integer.
1121
829c9ed9
TC
1122=item natural
1123
1124An integer greater or equal to zero.
1125
1126=item positiveint
1127
1128A positive integer.
1129
1130=item dh_one_line
1131
1132The field may not contain line breaks
1133
1134=back
1135
0ec4ac8a
TC
1136=head1 AUTHOR
1137
1138Tony Cook <tony@develop-help.com>
1139
1140=cut