more metadata generalization and modification
[bse.git] / site / cgi-bin / modules / DevHelp / Validate.pm
1 package DevHelp::Validate;
2 use strict;
3 require Exporter;
4 use vars qw(@EXPORT_OK @ISA);
5 @EXPORT_OK = qw(dh_validate dh_validate_hash dh_fieldnames dh_configure_fields);
6 @ISA = qw(Exporter);
7 use Carp qw(confess);
8
9 our $VERSION = "1.008";
10
11 my $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;
23
24 my %built_ins =
25   (
26    email => 
27    {
28     match => qr/^[^\s\@][^\@]*\@[\w.-]+\.\w+$/,
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    },
41    # international post code
42    dh_int_postcode =>
43    {
44     match => qr/[\w-](?:[^\w-]*[\w-]){3}/,
45     error => '$n is not a valid post code',
46    },
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    },
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    },
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    },
135    pastdate => 
136    {
137     date => 1,
138     maxdate => '+1d',
139     maxdatemsg => 'The date entered must be in the past',
140    },
141    time =>
142    {
143     time => 1,
144    },
145    integer =>
146    {
147     integer => 1,
148    },
149    natural => 
150    {
151     integer => '0-', # 0 or higher
152    },
153    positiveint =>
154    {
155     integer => '1-', # 1 or higher
156    },
157    dh_one_line => 
158    {
159     nomatch => qr/[\x0D\x0A]/,
160     error => '$n may only contain a single line',
161    },
162    real =>
163    {
164     real => 1,
165    },
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
173                       (?:[:.][0-5]\d)? # optional seconds
174                   |                    # or 12 hour time:
175                     (?:0?[1-9]|1[012]) # hour 1-12
176                      (?:[:.]           # optionally separator followed
177                       [0-5]\d          # by minutes
178                       (?:[:.][0-5]\d)? # optionall by seconds
179                     )? 
180                     [ap]m?             # followed by afternoon/morning
181                   )$!ix,
182     error=>'Invalid time $n',
183    },
184   );
185
186 sub new {
187   my ($class, %opts) = @_;
188
189   my $self = bless \%opts, $class;
190
191   # configure validation
192   my $fields = $self->{fields};
193   my $rules = $self->{rules} || {};
194
195   my %cfg_rules;
196   _get_cfg_fields(\%cfg_rules, $self->{cfg}, $self->{section}, $fields, $opts{dbh})
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
218     for my $override (qw(description required required_error maxlength range_error mindatemsg maxdatemsg ne_error)) {
219       if (defined $src->{$override} && !defined $dest->{$override}) {
220         $dest->{$override} = $src->{$override};
221       }
222     }
223
224     # but we add rules and required_if
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};
233
234       $dest->{rules} = $rules;
235     }
236     elsif ($src->{rules}) {
237       $dest->{rules} = $src->{rules};
238     }
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     }
245
246     $cfg_fields->{$field} = $dest if keys %$dest;
247   }
248
249   $self->{cfg_fields} = $cfg_fields;
250   $self->{cfg_rules} = $cfg_rules{rules};
251
252   return $self;
253 }
254
255 sub dh_validate {
256   my ($cgi, $errors, $validation, $cfg, $section) = @_;
257
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     )
267     ->validate($cgi, $errors);
268 }
269
270 sub dh_validate_hash {
271   my ($hash, $errors, $validation, $cfg, $section) = @_;
272
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     )
282     ->validate($hash, $errors);
283 }
284
285 sub _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   
292   for my $field ( keys %$cfg_fields ) {
293     $self->validate_field($field, $cfg_fields->{$field}, $cfg_rules, 
294                           $optional, $errors);
295   }
296   
297   !keys %$errors;
298 }
299
300 my @dow_tokens = qw(sun mon tue wed thu fri sat);
301 my @dow_names = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
302 my %dow_trans;
303 @dow_trans{@dow_tokens} = @dow_names;
304
305 sub 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}) {
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/)) {
319         ++$required;
320         last;
321       }
322     }
323   }
324
325   if (defined $info->{maxlength}) {
326     for my $testdata (@data) {
327       if (length $testdata > $info->{maxlength}) {
328         $errors->{$field} = _make_error($field, $info, {},
329                                         q!$n too long!);
330         return;
331       }
332     }
333   }
334
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       }
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       }
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;
394         }
395       }
396       if ($rule->{integer}) {
397         unless ($data =~ /^\s*([-+]?\d+)\s*$/) {
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         }
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         }
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         }
450         if ($rule->{mindate} || $rule->{maxdate}) {
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});
454             if ($workdate lt $mindate) {
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});
462             if ($workdate gt $maxdate) {
463               $errors->{$field} = 
464                 _make_error($field, $info, $rule,
465                             $info->{mindatemsg} || $rule->{maxdatemsg} || '$n is too late');
466             }
467           }
468         }
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         }
486       }
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       }
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       }
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       }
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       }
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       }
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       }
596       if ($rule->{ref}) {
597         my $method = $rule->{method}
598           or confess "Missing method in ref rule $rule_name";
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)) {
604           $errors->{$field} = _make_error($field, $info, $rule, 'No such $n');
605           last RULE;
606         }
607       }
608     }
609   }
610 }
611
612 sub _make_error {
613   my ($field, $info, $rule, $message) = @_;
614
615   $message = $rule->{error} || $message || 'Validation error on field $n';
616
617   my $name = $info->{description} || $field;
618   $message =~ s/\$n/$name/g;
619
620   return $message;
621 }
622
623 sub _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
699 sub _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
713 sub _get_cfg_fields {
714   my ($rules, $cfg, $section, $field_hash, $dbh) = @_;
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 );
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", "");
726
727   for my $field (@names) {
728     $cfg_fields->{$field} = {};
729     for my $cfg_name (qw(required rules description required_error range_error mindatemsg maxdatemsg ne_error), @extra_config) {
730       my $value = $cfg->entry($section, "${field}_$cfg_name");
731       if (defined $value) {
732         $cfg_fields->{$field}{$cfg_name} = $value;
733       }
734     }
735
736     my $values = $cfg->entry($section, "${field}_values");
737     if (defined $values) {
738       my @values;
739       if ($values eq "-sql") {
740         @values = _get_cfg_values_sql($cfg_fields->{$field}, $cfg, $field, $section, $dbh);
741       }
742       elsif ($values =~ /;/) {
743         for my $entry (split /;/, $values) {
744           if ($entry =~ /^([^=]*)=(.*)$/) {
745             push @values, [ $1, $2 ];
746           }
747           else {
748             push @values, [ $entry, $entry ];
749           }
750         }
751         _get_cfg_groups($cfg_fields->{$field}, $cfg, $field, $section);
752       }
753       else {
754         my $strip;
755         if ($values =~ s/:([^:]*)$//) {
756           $strip = $1;
757         }
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;
765         if ($strip) {
766           $_->[0] =~ s/^\Q$strip// for @values;
767         }
768         _get_cfg_groups($cfg_fields->{$field}, $cfg, $field, $section);
769       }
770       $cfg_fields->{$field}{values} = \@values;
771     }
772   }
773 }
774
775 sub dh_configure_fields {
776   my ($fields, $cfg, $section, $dbh) = @_;
777
778   my %cfg_rules;
779   _get_cfg_fields(\%cfg_rules, $cfg, $section, $fields, $dbh);
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
789     for my $override (grep $_ ne "rules", keys %$src) {
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}) {
797       my $rules = $src->{rules} || '';
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
815 sub _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
825 sub 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
836 package DevHelp::Validate::CGI;
837 use vars qw(@ISA);
838 @ISA = qw(DevHelp::Validate);
839
840 sub param {
841   my ($self, $field) = @_;
842
843   $self->{cgi}->param($field);
844 }
845
846 sub validate {
847   my ($self, $cgi, $errors) = @_;
848   
849   $self->{cgi} = $cgi;
850   
851   return $self->_validate($errors);
852 }
853
854 package DevHelp::Validate::Hash;
855 use vars qw(@ISA);
856 @ISA = qw(DevHelp::Validate);
857
858 sub 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
872 sub validate {
873   my ($self, $hash, $errors) = @_;
874
875   $self->{hash} = $hash;
876
877   return $self->_validate($errors);
878 }
879
880 1;
881
882 __END__
883
884 =head1 NAME
885
886 DevHelp::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
897 Performs simple validation of CGI or hash data.
898
899 =head1 RULES PARAMETER
900
901 The rules parameter is a hash with 2 keys:
902
903 =over
904
905 =item fields
906
907 A hash of field names, for each of which the value is a hash.
908
909 Each hash can have the following keys:
910
911 =over
912
913 =item rules
914
915 A simple rule name, a ';' separated list of rule names or an array
916 ref.
917
918 =item description
919
920 A short description of the field, for use in error messages.
921
922 =back
923
924 =item rules
925
926 A hash of rules.  See the rules description under L<CONFIGURED
927 VALIDATION>.
928
929 =back
930
931 =head1 CONFIGURED VALIDATION
932
933 Rules can be configured in the database.
934
935 For the specified section name, each key is a CGI field name.
936
937 The values of those keys gives the name of a validation rule, a string
938 id for internationlization of the field description and a default
939 field description, separated by commas.
940
941 Each validation rule name has a corresponding section,C<< [Validation
942 Rule I<rule-name>] >>, which describes the rule.  Rule names can also
943 refer to built-in rules,
944
945 Values in the validation rule section are:
946
947 =over
948
949 =item required
950
951 If this is non-zero the field is required.
952
953 =item match
954
955 If present, this is used as a regular expression the field must match.
956
957 =item nomatch
958
959 If present, this is used as a regular expression the field must not
960 match.
961
962 =item error
963
964 Message returned as the error if the field fails validation.
965
966 =item integer
967
968 If set to 1, simply ensures the value is an integer.
969
970 If set to a range I<integer>-I<integer> then ensures the value is an
971 integer in that range.
972
973 =item real
974
975 If set to 1, simply ensures the value is an real number.
976
977 If set to a range C<< I<real> - I<real> >> then ensures the value is
978 a real number in that range.
979
980 =item date
981
982 If set to 1, simply validates the value as a date.
983
984 Set mindate to specify a minimum date for range validation.  Uses
985 mindatemsg from the field or rule for the error message.
986
987 Set maxdate to specify a maximum date for range validation.  Uses
988 maxdatemsg from the field or rule for the error message.
989
990 Set C<dow> to a comma-separated list of number from 0 to 6, or 3
991 letter day of week abbreviations to require the date be only on those
992 days of week.  Uses C<dowmsg> from the field or rule for the error
993 message.
994
995 =item time
996
997 If true, validates that the value can be parsed by
998 L<DevHelp::Date/dh_parse_time()>.
999
1000 =item confirm
1001
1002 Specify another field that the field must be equal to, intended for
1003 password confirm validation.
1004
1005 =item notequal
1006
1007 A list of field names that may not be equal to the current field.  If
1008 the current field is in the list it is ignored, so you can use one
1009 rule to compare several fields with each other.  Uses ne_error from
1010 the field, or ne_error from the rule for customizing the error
1011 message.
1012
1013 =item ref
1014
1015 Requires that C<method> also be set.
1016
1017 Calls the specified method on the object or class specified by C<ref>
1018 with the value to check as a parameter.  The value is considered value
1019 if the result is true.  This is intended for checking the existence of
1020 objects in a collection.
1021
1022 Optionally C<before> can be an array ref or comma-separated list of
1023 parameters to supply before the value.
1024
1025 Optionally C<after> can be an array ref or comma-separated list of
1026 parameters to supply after the value.
1027
1028 =back
1029
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
1042 Matches any valid url, including mailto:, ftp:, etc.  No checking of
1043 the scheme is done.
1044
1045 =item weburl
1046
1047 Matches any valid http or https url.
1048
1049 =item newbieweburl
1050
1051 Matches web URLs with or without "http://" or "https://".
1052
1053 =item confirm
1054
1055 Treats the given field as a confirmation field for a password field
1056 "password".
1057
1058 =item newconfirm
1059
1060 Treats the given field as a confirmation field for an optional
1061 password field "password".
1062
1063 =item required
1064
1065 The field is required.  This should be used where the logic of the
1066 code requires a field, since it cannot be overridden by the config
1067 file.
1068
1069 =item abn
1070
1071 Valid Australian Business Number
1072
1073 =item creditcardnumber
1074
1075 Valid credit card number (no checksum checks are performed).
1076
1077 =item creditcardexpiry
1078
1079 Treats the field as the month part of a credit card expiry date, with
1080 the year field being the field with the same name, but "month"
1081 replaced with "year".  The date of expiry is required to be in the
1082 future.
1083
1084 =item miaa
1085
1086 Valid MIAA membership number.
1087
1088 =item decimal
1089
1090 Valid simple decimal number
1091
1092 =item money
1093
1094 Valid decimal number with 0 or 2 digits after the decimal point.
1095
1096 =item date
1097
1098 A valid date.  Currently dates are limited to Australian format
1099 dd/mm/yy or dd/mm/yyyy format dates.
1100
1101 =item birthdate
1102
1103 A valid date in the past.
1104
1105 =item adultbirthdate
1106
1107 A valid date at least 10 years in the past, at most 100 years in the
1108 past.
1109
1110 =item futuredate
1111
1112 A valid date in the future.
1113
1114 =item time
1115
1116 Parses as a time as per dh_parse_time().
1117
1118 =item integer
1119
1120 Any integer.
1121
1122 =item natural
1123
1124 An integer greater or equal to zero.
1125
1126 =item positiveint
1127
1128 A positive integer.
1129
1130 =item dh_one_line
1131
1132 The field may not contain line breaks
1133
1134 =back
1135
1136 =head1 AUTHOR
1137
1138 Tony Cook <tony@develop-help.com>
1139
1140 =cut