File Coverage

blib/lib/Data/FormValidator/Constraints.pm
Criterion Covered Total %
statement 274 349 78.5
branch 75 150 50.0
condition 65 156 41.6
subroutine 63 75 84.0
pod 19 32 59.3
total 496 762 65.0


line stmt bran cond sub pod time code
1             #
2             # Constraints.pm - Standard constraints for use in Data::FormValidator.
3             #
4             # This file is part of Data::FormValidator.
5             #
6             # Author: Francis J. Lacoste
7             # Maintainer: Mark Stosberg
8             #
9             # Copyright (C) 1999,2000 iNsu Innovations Inc.
10             # Copyright (C) 2001 Francis J. Lacoste
11             # Parts Copyright 1996-1999 by Michael J. Heins
12             # Parts Copyright 1996-1999 by Bruce Albrecht
13             #
14             # Parts of this module are based on work by
15             # Bruce Albrecht, contributed to MiniVend.
16             #
17             # Parts also based on work by Michael J. Heins
18             #
19             # This program is free software; you can redistribute it and/or modify
20             # it under the terms same terms as perl itself.
21             #
22             package Data::FormValidator::Constraints;
23 61     61   393 use base 'Exporter';
  61         120  
  61         5705  
24 61     61   368 use strict;
  61         123  
  61         2807  
25             our $AUTOLOAD;
26              
27             our $VERSION = 4.88;
28              
29 0         0 BEGIN {
30 61     61   330 use Carp;
  61         124  
  61         20076  
31 61     61   388 my @closures = (qw/
32             american_phone
33             cc_exp
34             cc_number
35             cc_type
36             email
37             ip_address
38             phone
39             postcode
40             province
41             state
42             state_or_province
43             zip
44             zip_or_postcode/);
45              
46             # This be optimized with some of the voodoo that CGI.pm
47             # uses to AUTOLOAD dynamic functions.
48 61         166 for my $func (@closures) {
49             # cc_number is defined statically
50 793 100       2126 unless ($func eq 'cc_number') {
51             # Notice we have to escape some characters
52             # in the subroutine, which is really a string here.
53              
54 732         3143 local $SIG{__DIE__} = \&confess;
55 732         2621 my $code = qq!
56             sub $func {
57             return sub {
58             my \$dfv = shift;
59             use Scalar::Util ();
60             die "first arg to $func was not an object. Must be called as a constraint_method."
61             unless ( Scalar::Util::blessed(\$dfv) && \$dfv->can('name_this') );
62              
63             \$dfv->name_this('$func') unless \$dfv->get_current_constraint_name();
64             no strict 'refs';
65             return &{"match_$func"}(\@_);
66             }
67             }
68             !;
69              
70 732 0 0 61 1 50740 eval "package Data::FormValidator::Constraints; $code";
  61 0 0 61 1 381  
  61 0 0 61 1 126  
  61 0 33 61 1 3493  
  61 0 0 61 1 355  
  61 0 0 61 1 125  
  61 50 0 61 1 3218  
  61 50 0 61 1 375  
  61 0 0 61 1 182  
  61 0 0 61 1 3134  
  61 0 0 61 1 325  
  61 0 0 61 1 153  
  61 0   61   3170  
  61 0   61   526  
  61 0   61   149  
  61 0   61   3193  
  61 0   61   354  
  61 0   61   150  
  61 0   61   3298  
  61 0   61   422  
  61 0   61   162  
  61 0   61   3448  
  61 0   61   336  
  61 0   61   137  
  61     0   3244  
  61     0   418  
  61     0   132  
  61     0   3254  
  61     1   355  
  61     0   138  
  61     0   3218  
  61     0   363  
  61     0   133  
  61     0   3012  
  61     0   331  
  61     0   131  
  61     0   3042  
  61         1134  
  61         156  
  61         3003  
  61         333  
  61         119  
  61         3102  
  61         392  
  61         123  
  61         3026  
  61         325  
  61         153  
  61         3156  
  61         379  
  61         128  
  61         3174  
  61         328  
  61         127  
  61         2975  
  61         375  
  61         169  
  61         2971  
  61         333  
  61         136  
  61         3227  
  61         368  
  61         129  
  61         3020  
  61         316  
  61         133  
  61         3071  
  61         377  
  61         119  
  61         3211  
  61         313  
  61         130  
  61         3237  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         2  
  1         13  
  1         5  
  1         2  
  1         5  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         96  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
71 732 50       4775 die "couldn't create $func: $@" if $@;
72             }
73             }
74              
75 61         245 my @FVs = (qw/
76             FV_length_between
77             FV_min_length
78             FV_max_length
79             FV_eq_with
80             FV_num_values
81             FV_num_values_between
82             /);
83              
84 61         461 our @EXPORT_OK = (
85             @closures,
86             @FVs,
87             qw(
88             valid_american_phone
89             valid_cc_exp
90             valid_cc_number
91             valid_cc_type
92             valid_email
93             valid_ip_address
94             valid_phone
95             valid_postcode
96             valid_province
97             valid_state
98             valid_state_or_province
99             valid_zip
100             valid_zip_or_postcode
101             match_american_phone
102             match_cc_exp
103             match_cc_number
104             match_cc_type
105             match_email
106             match_ip_address
107             match_phone
108             match_postcode
109             match_province
110             match_state
111             match_state_or_province
112             match_zip
113             match_zip_or_postcode)
114             );
115              
116 61         3228 our %EXPORT_TAGS = (
117             # regexp common is correctly empty here, because we handle the case on the fly with the import function below.
118             regexp_common => [],
119             closures => [ @closures, @FVs ],
120             validators => [qw/
121             valid_american_phone
122             valid_cc_exp
123             valid_cc_number
124             valid_cc_type
125             valid_email
126             valid_ip_address
127             valid_phone
128             valid_postcode
129             valid_province
130             valid_state
131             valid_state_or_province
132             valid_zip
133             valid_zip_or_postcode
134             /],
135             matchers => [qw/
136             match_american_phone
137             match_cc_exp
138             match_cc_number
139             match_cc_type
140             match_email
141             match_ip_address
142             match_phone
143             match_postcode
144             match_province
145             match_state
146             match_state_or_province
147             match_zip
148             match_zip_or_postcode
149             /],
150             );
151              
152             sub import {
153             # This is Regexp::Common support.
154             # Here we are handling cases that look like this:
155             #
156             # my_field => FV_foo_bar(-zoo=>'queue'),
157 130 100   130   1483 if (grep { m/^:regexp_common$/ } @_) {
  385         1396  
158 1         440 require Regexp::Common;
159 1         2522 import Regexp::Common 'RE_ALL';
160              
161 1         125849 for my $sub (grep { m/^RE_/} keys %Data::FormValidator::Constraints:: ) {
  236         378  
162 61     61   415 no strict 'refs';
  61         130  
  61         6358  
163 173         253 my $new_name = $sub;
164 173         438 $new_name =~ s/^RE_/FV_/;
165 173         602 *{caller() . "::$new_name"} = sub {
166 6     6   90 my @params = @_;
167             return sub {
168 9     9   11 my $dfv = shift;
169 9 50       20 $dfv->name_this($new_name) unless $dfv->get_current_constraint_name();
170              
171 61     61   382 no strict "refs";
  61         121  
  61         8589  
172 9         37 my $re = &$sub(-keep=>1,@params);
173 9         635 my ($match) = ($dfv->get_current_constraint_value =~ qr/^($re)$/);
174 9         41 return $dfv->untainted_constraint_value($match);
175             }
176 6         61 }
177 173         460 }
178             }
179              
180 130         43285 Data::FormValidator::Constraints->export_to_level(1,@_);
181             }
182              
183             }
184              
185              
186             # sub DESTROY {}
187              
188             =pod
189              
190             =head1 NAME
191              
192             Data::FormValidator::Constraints - Basic sets of constraints on input profile.
193              
194             =head1 SYNOPSIS
195              
196             use Data::FormValidator::Constraints qw(:closures);
197              
198             In an Data::FormValidator profile:
199              
200             constraint_methods => {
201             email => email(),
202             phone => american_phone(),
203             first_names => {
204             constraint_method => FV_max_length(3),
205             name => 'my_custom_name',
206             },
207             },
208             msgs => {
209             constraints => {
210             my_custom_name => 'My message',
211             },
212             },
213              
214              
215              
216             =head1 DESCRIPTION
217              
218             These are the builtin constraints that can be specified by name in the input
219             profiles.
220              
221             Be sure to check out the SEE ALSO section for even more pre-packaged
222             constraints you can use.
223              
224             =cut
225              
226             sub AUTOLOAD {
227 34     34   9897 my $name = $AUTOLOAD;
228              
229 61     61   346 no strict qw/refs/;
  61         143  
  61         124237  
230              
231 34         155 $name =~ m/^(.*::)(valid_|RE_)(.*)/;
232              
233 34         109 my ($pkg,$prefix,$sub) = ($1,$2,$3);
234              
235             #warn "hello! my ($pkg,$prefix,$sub) = ($1,$2,$3);";
236              
237             # Since all the valid_* routines are essentially identical we're
238             # going to generate them dynamically from match_ routines with the same names.
239 34 50 33     156 if ((defined $prefix) and ($prefix eq 'valid_')) {
240 34         53 return defined &{$pkg.'match_' . $sub}(@_);
  34         146  
241             }
242             }
243              
244             =head2 FV_length_between(1,23)
245              
246             =head2 FV_max_length(23)
247              
248             =head2 FV_min_length(1)
249              
250             use Data::FormValidator::Constraints qw(
251             FV_length_between
252             FV_min_length
253             FV_max_length
254             );
255              
256             constraint_methods => {
257              
258             # specify a min and max, inclusive
259             last_name => FV_length_between(1,23),
260              
261             }
262              
263             Specify a length constraint for a field.
264              
265             These constraints have a different naming convention because they are higher-order
266             functions. They take input and return a code reference to a standard constraint
267             method. A constraint name of C, C, or C will be set,
268             corresponding to the function name you choose.
269              
270             The checks are all inclusive, so a max length of '100' will allow the length 100.
271              
272             Length is measured in perl characters as opposed to bytes or anything else.
273              
274             This constraint I untaint your data if you have untainting turned on. However,
275             a length check alone may not be enough to insure the safety of the data you are receiving.
276             Using additional constraints to check the data is encouraged.
277              
278             =cut
279              
280             sub FV_length_between {
281 8     8 1 15 my ($min,$max) = @_;
282 8 50 33     25 if (not (defined $min and defined $max)) {
283 0         0 croak "min and max are required";
284             }
285             return sub {
286 8     8   15 my ($dfv,$value) = @_;
287 8 100       17 $dfv->name_this('length_between') unless $dfv->get_current_constraint_name();
288 8 100 100     1068 return undef if ( ( length($value) > $max ) || ( length($value) < $min) );
289             # Use a regexp to untaint
290 3         348 $value=~/(.*)/s;
291 3         8 return $dfv->untainted_constraint_value($1);
292             }
293 8         48 }
294              
295             sub FV_max_length {
296 6     6 1 1069 my ($max) = @_;
297 6 50       16 croak "max is required" unless defined $max;
298             return sub {
299 6     6   13 my ($dfv,$value) = @_;
300 6 100       13 $dfv->name_this('max_length') unless $dfv->get_current_constraint_name();
301 6 100       692 return undef if ( length($value) > $max );
302             # Use a regexp to untaint
303 2         341 $value=~/(.*)/s;
304 2         5 return $dfv->untainted_constraint_value($1);
305             }
306 6         41 }
307              
308             sub FV_min_length {
309 5     5 1 9 my ($min) = @_;
310 5 50       9 croak "min is required" unless defined $min;
311             return sub {
312 4     4   6 my ($dfv,$value) = @_;
313 4 50       11 $dfv->name_this('min_length') unless $dfv->get_current_constraint_name();
314 4 100       687 return undef if ( length($value) < $min );
315             # Use a regexp to untaint
316 2         366 $value=~/(.*)/s;
317 2         7 return $dfv->untainted_constraint_value($1);
318             }
319 5         19 }
320              
321             =head2 FV_eq_with
322              
323             use Data::FormValidator::Constraints qw( FV_eq_with );
324              
325             constraint_methods => {
326             password => FV_eq_with('password_confirm'),
327             }
328              
329             Compares the current field to another field.
330             A constraint name of C will be set.
331              
332             =cut
333              
334             sub FV_eq_with {
335 2     2 1 462 my ($other_field) = @_;
336             return sub {
337 2     2   5 my $dfv = shift;
338 2 50       12 $dfv->name_this('eq_with') unless $dfv->get_current_constraint_name();
339              
340 2         9 my $curr_val = $dfv->get_current_constraint_value;
341              
342 2         8 my $data = $dfv->get_filtered_data;
343             # Sometimes the data comes through both ways...
344 2 50       13 my $other_val = (ref $data->{$other_field}) ? $data->{$other_field}[0] : $data->{$other_field};
345              
346 2         8 return ($curr_val eq $other_val);
347             }
348              
349 2         26 }
350              
351             =head2 FV_num_values
352              
353             use Data::FormValidator::Constraints qw ( FV_num_values );
354              
355             constraint_methods => {
356             attachments => FV_num_values(4),
357             }
358              
359             Checks the number of values in the array named by this param.
360             Note that this is useful for making sure that only one value was passed for a
361             given param (by supplying a size argument of 1).
362             A constraint name of C will be set.
363              
364             =cut
365              
366             sub FV_num_values {
367 2   33 2 1 78 my $size = shift || croak 'size argument is required';
368             return sub {
369 3     3   8 my $dfv = shift;
370 3         8 $dfv->name_this('num_values');
371 3         6 my $param = $dfv->get_current_constraint_field();
372 3         7 my $value = $dfv->get_filtered_data()->{$param};
373              
374             # If there's an arrayref of values provided, test the number of them found
375             # against the number of them of required
376 3 50 33     12 if (defined $value and ref $value eq 'ARRAY') {
    0          
377 3         6 my $num_values_found = scalar @$value;
378 3         7 return ($num_values_found == $size);
379             }
380             # If a size of 1 was requested, there was not an arrayref of values,
381             # there must be exactly one value.
382             elsif ($size == 1) {
383 0         0 return 1;
384             }
385             # Any other case is failure.
386             else {
387 0         0 return 0;
388             }
389             }
390 2         10 }
391              
392             =head2 FV_num_values_between
393              
394             use Data::FormValidator::Constraints qw ( FV_num_values_between );
395              
396             constraint_methods => {
397             attachments => FV_num_values_between(1,4),
398             }
399              
400             Checks that the number of values in the array named by this param is between
401             the supplied bounds (inclusively).
402             A constraint name of C will be set.
403              
404             =cut
405              
406             sub FV_num_values_between {
407 2     2 1 6 my ($min, $max) = @_;
408 2 50 33     11 croak 'min and max arguments are required' unless $min && $max;
409             return sub {
410 2     2   3 my $dfv = shift;
411 2         6 $dfv->name_this('num_values_between');
412 2         5 my $param = $dfv->get_current_constraint_field();
413 2         5 my $value = $dfv->get_filtered_data()->{$param};
414              
415 2 50       6 if (ref($value) eq 'ARRAY') {
416 2         4 my $num_values = scalar @$value;
417              
418             return(
419             (
420 2 100 66     8 $num_values >= $min
421             && $num_values <= $max
422             ) ? 1 : 0
423             );
424             } else {
425 0 0 0     0 if ($min <= 1 && $max >= 1) {
426             # Single value is allowed
427 0         0 return 1;
428             } else {
429 0         0 return 0;
430             }
431             }
432             }
433 2         17 }
434              
435             =head2 email
436              
437             Checks if the email LOOKS LIKE an email address. This should be sufficient
438             99% of the time.
439              
440             Look elsewhere if you want something super fancy that matches every possible variation
441             that is valid in the RFC, or runs out and checks some MX records.
442              
443             =cut
444              
445             # Many of the following validators are taken from
446             # MiniVend 3.14. (http://www.minivend.com)
447             # Copyright 1996-1999 by Michael J. Heins
448              
449             sub match_email {
450 38     38 0 1032 my $in_email = shift;
451              
452 38         4614 require Email::Valid;
453 38         1237406 my $valid_email;
454              
455             # The extra check that the result matches the input prevents
456             # an address like this from being considered valid: Joe Smith
457 38 100 100     308 if ( ($valid_email = Email::Valid->address($in_email) )
458             and ($valid_email eq $in_email)) {
459 11         9783 return $valid_email;
460             }
461             else {
462 27         18787 return undef;
463             }
464             }
465              
466             my $state = <
467             AL AK AZ AR CA CO CT DE FL GA HI ID IL IN IA KS KY LA ME MD
468             MA MI MN MS MO MT NE NV NH NJ NM NY NC ND OH OK OR PA PR RI
469             SC SD TN TX UT VT VA WA WV WI WY DC AP FP FPO APO GU VI
470             EOF
471              
472             my $province = <
473             AB BC MB NB NF NL NS NT NU ON PE QC SK YT YK
474             EOF
475              
476             =head2 state_or_province
477              
478             This one checks if the input correspond to an american state or a canadian
479             province.
480              
481             =cut
482              
483             sub match_state_or_province {
484 4     4 0 598 my $match;
485 4 50       11 if ($match = match_state(@_)) {
486 0         0 return $match;
487             }
488             else {
489 4         10 return match_province(@_);
490             }
491             }
492              
493             =head2 state
494              
495             This one checks if the input is a valid two letter abbreviation of an
496             American state.
497              
498             =cut
499              
500             sub match_state {
501 11     11 0 666 my $val = shift;
502 11 100       198 if ($state =~ /\b($val)\b/i) {
503 2         16 return $1;
504             }
505 9         41 else { return undef; }
506             }
507              
508             =head2 province
509              
510             This checks if the input is a two letter Canadian province
511             abbreviation.
512              
513             =cut
514              
515             sub match_province {
516 10     10 0 687 my $val = shift;
517 10 100       131 if ($province =~ /\b($val)\b/i) {
518 4         48 return $1;
519             }
520 6         38 else { return undef; }
521             }
522              
523             =head2 zip_or_postcode
524              
525             This constraints checks if the input is an American zipcode or a
526             Canadian postal code.
527              
528             =cut
529              
530             sub match_zip_or_postcode {
531 4     4 0 560 my $match;
532 4 100       15 if ($match = match_zip(@_)) {
533 2         14 return $match;
534             }
535             else {
536 2         7 return match_postcode(@_)
537             };
538             }
539             =pod
540              
541             =head2 postcode
542              
543             This constraints checks if the input is a valid Canadian postal code.
544              
545             =cut
546              
547             sub match_postcode {
548 6     6 0 660 my $val = shift;
549             #$val =~ s/[_\W]+//g;
550 6 100       37 if ($val =~ /^([ABCEGHJKLMNPRSTVXYabceghjklmnprstvxy][_\W]*\d[_\W]*[A-Za-z][_\W]*[- ]?[_\W]*\d[_\W]*[A-Za-z][_\W]*\d[_\W]*)$/) {
551 2         22 return $1;
552             }
553 4         31 else { return undef; }
554             }
555              
556             =head2 zip
557              
558             This input validator checks if the input is a valid american zipcode :
559             5 digits followed by an optional mailbox number.
560              
561             =cut
562              
563             sub match_zip {
564 12     12 0 600 my $val = shift;
565 12 100       51 if ($val =~ /^(\s*\d{5}(?:[-]\d{4})?\s*)$/) {
566 6         32 return $1;
567             }
568 6         26 else { return undef; }
569             }
570              
571             =head2 phone
572              
573             This one checks if the input looks like a phone number, (if it
574             contains at least 6 digits.)
575              
576             =cut
577              
578             sub match_phone {
579 6     6 0 611 my $val = shift;
580              
581 6 100       56 if ($val =~ /^((?:\D*\d\D*){6,})$/) {
582 4         26 return $1;
583             }
584 2         16 else { return undef; }
585             }
586              
587             =head2 american_phone
588              
589             This constraints checks if the number is a possible North American style
590             of phone number : (XXX) XXX-XXXX. It has to contains 7 or more digits.
591              
592             =cut
593              
594             sub match_american_phone {
595 5     5 0 764 my $val = shift;
596              
597 5 100       42 if ($val =~ /^((?:\D*\d\D*){7,})$/) {
598 2         17 return $1;
599             }
600 3         26 else { return undef; }
601             }
602              
603              
604             =head2 cc_number
605              
606             This constraint references the value of a credit card type field.
607              
608             constraint_methods => {
609             cc_no => cc_number({fields => ['cc_type']}),
610             }
611              
612              
613             The number is checked only for plausibility, it checks if the number could
614             be valid for a type of card by checking the checksum and looking at the number
615             of digits and the number of digits of the number.
616              
617             This functions is only good at catching typos. IT DOESN'T
618             CHECK IF THERE IS AN ACCOUNT ASSOCIATED WITH THE NUMBER.
619              
620             =cut
621              
622             # This one is taken from the contributed program to
623             # MiniVend by Bruce Albrecht
624              
625             # XXX raise exception on bad/missing params?
626             sub cc_number {
627 1     1 1 551 my $attrs = shift;
628             return undef unless $attrs && ref($attrs) eq 'HASH'
629 1 50 33     14 && exists $attrs->{fields} && ref($attrs->{fields}) eq 'ARRAY';
      33        
      33        
630              
631 1         3 my ($cc_type_field) = @{ $attrs->{fields} };
  1         3  
632 1 50       4 return undef unless $cc_type_field;
633              
634             return sub {
635 12     12   18 my $dfv = shift;
636 12         28 my $data = $dfv->get_filtered_data;
637              
638             return match_cc_number(
639             $dfv->get_current_constraint_value,
640 12         26 $data->{$cc_type_field}
641             );
642 1         10 };
643             }
644              
645             sub match_cc_number {
646 28     28 0 1039 my ( $the_card, $card_type ) = @_;
647 28         50 my $orig_card = $the_card; #used for return match at bottom
648 28         42 my ($index, $digit, $product);
649 28         37 my $multiplier = 2; # multiplier is either 1 or 2
650 28         43 my $the_sum = 0;
651              
652 28 50       63 return undef if length($the_card) == 0;
653              
654             # check card type
655 28 50       88 return undef unless $card_type =~ /^[admv]/i;
656              
657 28 100 66     326 return undef if ($card_type =~ /^v/i && substr($the_card, 0, 1) ne "4") ||
      100        
      66        
      66        
      100        
      100        
      66        
      66        
      66        
658             ($card_type =~ /^m/i && substr($the_card, 0, 1) ne "5" &&
659             substr($the_card, 0, 1) ne "2") ||
660             ($card_type =~ /^d/i && substr($the_card, 0, 4) ne "6011") ||
661             ($card_type =~ /^a/i && substr($the_card, 0, 2) ne "34" &&
662             substr($the_card, 0, 2) ne "37");
663              
664             # check for valid number of digits.
665 24         55 $the_card =~ s/\s//g; # strip out spaces
666 24 50       88 return undef if $the_card !~ /^\d+$/;
667              
668 24         56 $digit = substr($the_card, 0, 1);
669 24         36 $index = length($the_card)-1;
670 24 50 66     214 return undef if ($digit == 3 && $index != 14) ||
      66        
      66        
      33        
      66        
      33        
      66        
      66        
      33        
671             ($digit == 4 && $index != 12 && $index != 15) ||
672             ($digit == 5 && $index != 15) ||
673             ($digit == 6 && $index != 13 && $index != 15);
674              
675              
676             # calculate checksum.
677 24         56 for ($index--; $index >= 0; $index --)
678             {
679 354         443 $digit=substr($the_card, $index, 1);
680 354         432 $product = $multiplier * $digit;
681 354 100       527 $the_sum += $product > 9 ? $product - 9 : $product;
682 354         566 $multiplier = 3 - $multiplier;
683             }
684 24         34 $the_sum %= 10;
685 24 100       48 $the_sum = 10 - $the_sum if $the_sum;
686              
687             # return whether checksum matched.
688 24 100       51 if ($the_sum == substr($the_card, -1)) {
689 18 50       119 if ($orig_card =~ /^([\d\s]*)$/) { return $1; }
  18         104  
690 0         0 else { return undef; }
691             }
692             else {
693 6         22 return undef;
694             }
695             }
696              
697             =head2 cc_exp
698              
699             This one checks if the input is in the format MM/YY or MM/YYYY and if
700             the MM part is a valid month (1-12) and if that date is not in the past.
701              
702             =cut
703              
704             sub match_cc_exp {
705 4     4 0 578 my $val = shift;
706 4         6 my ($matched_month, $matched_year);
707              
708 4         14 my ($month, $year) = split('/', $val);
709 4 100       34 return undef if $month !~ /^(\d+)$/;
710 2         5 $matched_month = $1;
711              
712 2 50       10 return undef if $year !~ /^(\d+)$/;
713 2         4 $matched_year = $1;
714              
715 2 50 33     15 return undef if $month <1 || $month > 12;
716 2 50       12 $year += ($year < 70) ? 2000 : 1900 if $year < 1900;
    50          
717 2         51 my @now=localtime();
718 2         6 $now[5] += 1900;
719 2 50 33     13 return undef if ($year < $now[5]) || ($year == $now[5] && $month <= $now[4]);
      33        
720              
721 2         20 return "$matched_month/$matched_year";
722             }
723              
724             =head2 cc_type
725              
726             This one checks if the input field starts by M(asterCard), V(isa),
727             A(merican express) or D(iscovery).
728              
729             =cut
730              
731             sub match_cc_type {
732 4     4 0 599 my $val = shift;
733 4 100       19 if ($val =~ /^([MVAD].*)$/i) { return $1; }
  2         16  
734 2         15 else { return undef; }
735             }
736              
737             =head2 ip_address
738              
739             This checks if the input is formatted like a dotted decimal IP address (v4).
740             For other kinds of IP address method, See L which provides
741             several more options. L explains how we easily integrate
742             with Regexp::Common.
743              
744             =cut
745              
746             # contributed by Juan Jose Natera Abreu
747              
748             sub match_ip_address {
749 6     6 0 587 my $val = shift;
750 6 100       29 if ($val =~ m/^((\d+)\.(\d+)\.(\d+)\.(\d+))$/) {
751 4 100 66     77 if
      33        
      66        
      33        
      33        
      33        
      33        
752             (($2 >= 0 && $2 <= 255) && ($3 >= 0 && $3 <= 255) && ($4 >= 0 && $4 <= 255) && ($5 >= 0 && $5 <= 255)) {
753 3         21 return $1;
754             }
755 1         5 else { return undef; }
756             }
757 2         42 else { return undef; }
758             }
759              
760              
761             1;
762              
763             __END__