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