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__ |