line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# perl |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Class Scalar::Validation |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# Simple rule based validation package for scalar values |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# Ralf Peine, Mon Jul 21 16:28:11 2014 |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# More documentation at the end of file |
10
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
$VERSION = "0.613"; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
package Scalar::Validation; |
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
1
|
|
38339
|
use base qw (Exporter); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
76
|
|
17
|
|
|
|
|
|
|
|
18
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
29
|
|
19
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
121
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our @EXPORT = qw(); |
22
|
|
|
|
|
|
|
our @EXPORT_OK = qw (validate is_valid validate_and_correct npar named_parameter par parameter |
23
|
|
|
|
|
|
|
get_rules rule_known declare_rule delete_rule replace_rule enum Enum enum_explained Enum_explained |
24
|
|
|
|
|
|
|
greater_than greater_equal less_than less_equal equal_to g_t g_e l_t l_e |
25
|
|
|
|
|
|
|
is_a |
26
|
|
|
|
|
|
|
convert_to_named_params parameters_end p_end |
27
|
|
|
|
|
|
|
validation_trouble validation_messages get_and_reset_validation_messages prepare_validation_mode); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( |
30
|
|
|
|
|
|
|
all => [qw(validate is_valid validate_and_correct npar named_parameter par parameter |
31
|
|
|
|
|
|
|
get_rules rule_known declare_rule delete_rule replace_rule enum Enum enum_explained Enum_explained |
32
|
|
|
|
|
|
|
greater_than greater_equal less_than less_equal equal_to g_t g_e l_t l_e |
33
|
|
|
|
|
|
|
is_a |
34
|
|
|
|
|
|
|
convert_to_named_params parameters_end p_end |
35
|
|
|
|
|
|
|
validation_trouble validation_messages get_and_reset_validation_messages prepare_validation_mode)], |
36
|
|
|
|
|
|
|
); |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
102
|
|
39
|
1
|
|
|
1
|
|
15433
|
use Data::Dumper; |
|
1
|
|
|
|
|
12066
|
|
|
1
|
|
|
|
|
13343
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
42
|
|
|
|
|
|
|
# |
43
|
|
|
|
|
|
|
# Initiliazation |
44
|
|
|
|
|
|
|
# |
45
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
_init_run_API(); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
50
|
|
|
|
|
|
|
# |
51
|
|
|
|
|
|
|
# default actions, not changable |
52
|
|
|
|
|
|
|
# |
53
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
my $croak_sub = sub { croak "Error: ",@_; }; |
56
|
|
|
|
|
|
|
my $get_caller_info_default = sub { |
57
|
|
|
|
|
|
|
my ($module, $file_name, $line, $sub_name); |
58
|
|
|
|
|
|
|
$sub_name = 'Scalar::Validation'; |
59
|
|
|
|
|
|
|
my $call_level = 1; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
while ($sub_name =~ /^Scalar::Validation/) { |
62
|
|
|
|
|
|
|
($module, $file_name, $line, $sub_name) = caller($call_level++); |
63
|
|
|
|
|
|
|
$sub_name = '' unless $sub_name; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
$sub_name = "MAIN" unless $sub_name; |
67
|
|
|
|
|
|
|
return $sub_name; |
68
|
|
|
|
|
|
|
}; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
71
|
|
|
|
|
|
|
# |
72
|
|
|
|
|
|
|
# variables my be overwritten by user |
73
|
|
|
|
|
|
|
# |
74
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
our $message_store = undef; # local $Scalar::Validation::message_store = []; # to start storing messages |
77
|
|
|
|
|
|
|
our $trouble_level = 0; # to count failed validations. Not affected by is_valid(...) |
78
|
|
|
|
|
|
|
our $off = 0; # no validation checks if $off == 1 |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
81
|
|
|
|
|
|
|
# |
82
|
|
|
|
|
|
|
# actions, changable |
83
|
|
|
|
|
|
|
# |
84
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
our $fail_action = $croak_sub; |
87
|
|
|
|
|
|
|
our $get_caller_info = $get_caller_info_default; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
90
|
|
|
|
|
|
|
# |
91
|
|
|
|
|
|
|
# private vars of Validation "Instance" |
92
|
|
|
|
|
|
|
# |
93
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
94
|
|
|
|
|
|
|
my $non_blessed = { |
95
|
|
|
|
|
|
|
REF => 1, |
96
|
|
|
|
|
|
|
ARRAY => 1, |
97
|
|
|
|
|
|
|
HASH => 1, |
98
|
|
|
|
|
|
|
}; |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
my $special_rules; |
101
|
|
|
|
|
|
|
my $rule_store; |
102
|
|
|
|
|
|
|
my $get_content_subs; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
106
|
|
|
|
|
|
|
# |
107
|
|
|
|
|
|
|
# normal rules, can be added, replaced, removed |
108
|
|
|
|
|
|
|
# |
109
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
$rule_store = { |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# --- This rules are needed for Validation.pm to work, don't delete or change! --- |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
Defined => { -name => 'Defined', |
116
|
|
|
|
|
|
|
-where => sub { defined $_ }, |
117
|
|
|
|
|
|
|
-message => sub { "value is not defined" }, |
118
|
|
|
|
|
|
|
-description => "Value is defined", |
119
|
|
|
|
|
|
|
}, |
120
|
|
|
|
|
|
|
Filled => { -name => 'Filled', |
121
|
|
|
|
|
|
|
-where => sub { defined $_ and ref($_) eq '' and $_ ne '' }, |
122
|
|
|
|
|
|
|
-message => sub { "value is not set" }, |
123
|
|
|
|
|
|
|
-description => "Value is Scalar and defined and not empty ('')", |
124
|
|
|
|
|
|
|
}, |
125
|
|
|
|
|
|
|
Empty => { -name => 'Empty', |
126
|
|
|
|
|
|
|
-where => sub { !defined $_ or $_ eq '' }, |
127
|
|
|
|
|
|
|
-message => sub { "value $_ has to be empty" }, |
128
|
|
|
|
|
|
|
-description => "Value is not defined or ''", |
129
|
|
|
|
|
|
|
}, |
130
|
|
|
|
|
|
|
Optional => { -name => 'Optional', |
131
|
|
|
|
|
|
|
-where => sub { 1; }, |
132
|
|
|
|
|
|
|
-message => sub { "value is optional" }, |
133
|
|
|
|
|
|
|
-description => "Value is optional, cannot fail. Use as last entry in -Or rule.", |
134
|
|
|
|
|
|
|
}, |
135
|
|
|
|
|
|
|
String => { -name => 'String', |
136
|
|
|
|
|
|
|
-where => sub { defined $_ and ref($_) eq '' }, |
137
|
|
|
|
|
|
|
-message => sub { "value $_ is not a string" }, |
138
|
|
|
|
|
|
|
-description => "Values is a Scalar and defined", |
139
|
|
|
|
|
|
|
}, |
140
|
|
|
|
|
|
|
Int => { -name => 'Int', |
141
|
|
|
|
|
|
|
-as => 'Filled', |
142
|
|
|
|
|
|
|
-where => sub { /^[\+\-]?\d+$/ }, |
143
|
|
|
|
|
|
|
-message => sub { "value $_ is not an integer" }, |
144
|
|
|
|
|
|
|
-description => "Value is an integer", |
145
|
|
|
|
|
|
|
}, |
146
|
|
|
|
|
|
|
Even => { -name => 'Even', |
147
|
|
|
|
|
|
|
-as => 'Int', |
148
|
|
|
|
|
|
|
-where => sub { $_ % 2 ? 0: 1; }, |
149
|
|
|
|
|
|
|
-message => sub { "value $_ is not an integer or not even"}, |
150
|
|
|
|
|
|
|
-description => 'Value is an even integer ($_ % 2 == 0)', |
151
|
|
|
|
|
|
|
}, |
152
|
|
|
|
|
|
|
Scalar => { -name => 'Scalar', |
153
|
|
|
|
|
|
|
-where => sub { ref($_) eq '' }, |
154
|
|
|
|
|
|
|
-message => sub { "value $_ is not a scalar" }, |
155
|
|
|
|
|
|
|
-description => 'Value is a Scalar : ref ($_) eq ""', |
156
|
|
|
|
|
|
|
}, |
157
|
|
|
|
|
|
|
Ref => { -name => 'Ref', |
158
|
|
|
|
|
|
|
-where => sub { $_ and ref($_) ne '' }, |
159
|
|
|
|
|
|
|
-message => sub { "value $_ is not a reference" }, |
160
|
|
|
|
|
|
|
-description => "Value is a reference and not a scalar.", |
161
|
|
|
|
|
|
|
}, |
162
|
|
|
|
|
|
|
ArrayRef => { -name => 'ArrayRef', |
163
|
|
|
|
|
|
|
-where => sub { $_ and ref($_) eq 'ARRAY' }, |
164
|
|
|
|
|
|
|
-message => sub { "value $_ is not a array reference" }, |
165
|
|
|
|
|
|
|
-description => "Value is an Array reference.", |
166
|
|
|
|
|
|
|
}, |
167
|
|
|
|
|
|
|
HashRef => { -name => 'HashRef', |
168
|
|
|
|
|
|
|
-where => sub { $_ and ref($_) eq 'HASH' }, |
169
|
|
|
|
|
|
|
-message => sub { "value $_ is not a hash reference" }, |
170
|
|
|
|
|
|
|
-description => "Value is a Hash reference.", |
171
|
|
|
|
|
|
|
}, |
172
|
|
|
|
|
|
|
CodeRef => { -name => 'CodeRef', |
173
|
|
|
|
|
|
|
-where => sub { $_ and ref($_) eq 'CODE' }, |
174
|
|
|
|
|
|
|
-message => sub { "value $_ is not a code reference" }, |
175
|
|
|
|
|
|
|
-description => "Value is a Code reference.", |
176
|
|
|
|
|
|
|
}, |
177
|
|
|
|
|
|
|
Class => { -name => 'Class', |
178
|
|
|
|
|
|
|
-where => sub { return 0 unless $_; |
179
|
|
|
|
|
|
|
my $type_name = ref($_); |
180
|
|
|
|
|
|
|
!$type_name || $non_blessed->{$type_name} ? 0: 1; |
181
|
|
|
|
|
|
|
}, |
182
|
|
|
|
|
|
|
-message => sub { "value $_ is not a reference" }, |
183
|
|
|
|
|
|
|
-description => "Value is a reference and not a scalar.", |
184
|
|
|
|
|
|
|
}, |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# --- Some additional global rules -------------------- |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
ExistingFile => { -name => 'ExistingFile', |
189
|
|
|
|
|
|
|
-as => 'Filled', |
190
|
|
|
|
|
|
|
-where => sub { -f $_ }, |
191
|
|
|
|
|
|
|
-message => sub { "$_ is not a valid name of an existing file"}, |
192
|
|
|
|
|
|
|
-description => "File with given file name has to exist" |
193
|
|
|
|
|
|
|
}, |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
Bool => { -name => 'Bool', |
196
|
|
|
|
|
|
|
-where => sub { ref ($_) ? 0: 1 }, |
197
|
|
|
|
|
|
|
-message => sub { "value $_ is not a bool value" }, |
198
|
|
|
|
|
|
|
-description => "Value is a Scalar, all values including undef allowed", |
199
|
|
|
|
|
|
|
}, |
200
|
|
|
|
|
|
|
PositiveInt => { -name => 'PositiveInt', |
201
|
|
|
|
|
|
|
-as => 'Int', |
202
|
|
|
|
|
|
|
-where => sub { $_ >= 0 }, |
203
|
|
|
|
|
|
|
-message => sub { "value $_ is not a positive integer" }, |
204
|
|
|
|
|
|
|
-description => "Value is a positive integer", |
205
|
|
|
|
|
|
|
}, |
206
|
|
|
|
|
|
|
NegativeInt => { -name => 'NegativeInt', |
207
|
|
|
|
|
|
|
-as => 'Int', |
208
|
|
|
|
|
|
|
-where => sub { $_ < 0 }, |
209
|
|
|
|
|
|
|
-message => sub { "value $_ is not a negative integer" }, |
210
|
|
|
|
|
|
|
-description => "Value is a negative Integer", |
211
|
|
|
|
|
|
|
}, |
212
|
|
|
|
|
|
|
Float => { -name => 'Float', |
213
|
|
|
|
|
|
|
-as => 'Filled', |
214
|
|
|
|
|
|
|
-where => sub { /^[\+\-]?\d+(\.\d+)?([Ee][\+-]?\d+)?$/ }, |
215
|
|
|
|
|
|
|
-message => sub { "value $_ is not a float" }, |
216
|
|
|
|
|
|
|
-description => "Value is a floating number with optional exponent", |
217
|
|
|
|
|
|
|
}, |
218
|
|
|
|
|
|
|
PositiveFloat => { -name => 'PositiveFloat', |
219
|
|
|
|
|
|
|
-as => 'Float', |
220
|
|
|
|
|
|
|
-where => sub { $_ > 0 }, |
221
|
|
|
|
|
|
|
-message => sub { "value $_ is not a positive float" }, |
222
|
|
|
|
|
|
|
-description => "Value is a positive floating number with optional exponent", |
223
|
|
|
|
|
|
|
}, |
224
|
|
|
|
|
|
|
NegativeFloat => { -name => 'NegativeFloat', |
225
|
|
|
|
|
|
|
-as => 'Float', |
226
|
|
|
|
|
|
|
-where => sub { $_ < 0 }, |
227
|
|
|
|
|
|
|
-message => sub { "value $_ is not a negative float" }, |
228
|
|
|
|
|
|
|
-description => "Value is a negative floating number with optional exponent", |
229
|
|
|
|
|
|
|
}, |
230
|
|
|
|
|
|
|
}; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
233
|
|
|
|
|
|
|
# |
234
|
|
|
|
|
|
|
# gets content of ref container |
235
|
|
|
|
|
|
|
# |
236
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
$get_content_subs = { |
239
|
|
|
|
|
|
|
HASH => sub { my @keys = keys %$_; return scalar @keys ? \@keys: undef; }, |
240
|
|
|
|
|
|
|
ARRAY => sub { return scalar @$_ ? $_: undef; }, |
241
|
|
|
|
|
|
|
}; |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
244
|
|
|
|
|
|
|
# |
245
|
|
|
|
|
|
|
# special rules (combined and other), not changable |
246
|
|
|
|
|
|
|
# |
247
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
$special_rules = { |
250
|
|
|
|
|
|
|
-Optional => { |
251
|
|
|
|
|
|
|
-value_position => '-9', |
252
|
|
|
|
|
|
|
-code => sub { |
253
|
|
|
|
|
|
|
# my $subject_info = shift || ''; |
254
|
|
|
|
|
|
|
# my $rule_info = shift; |
255
|
|
|
|
|
|
|
local $_ = $_[2]; |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# skip one param if special rule follows |
258
|
|
|
|
|
|
|
my $special_rule = $special_rules->{$_[1]}; |
259
|
|
|
|
|
|
|
if ($special_rule) { |
260
|
|
|
|
|
|
|
$_ = $_[$special_rule->{-value_position}]; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
; |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
return $_ if !defined $_; # value not set |
265
|
|
|
|
|
|
|
return validate(@_); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
}, |
268
|
|
|
|
|
|
|
-And => { |
269
|
|
|
|
|
|
|
-value_position => 3, |
270
|
|
|
|
|
|
|
-code => sub { |
271
|
|
|
|
|
|
|
my $subject_info = shift || ''; |
272
|
|
|
|
|
|
|
my $rule_list = shift; |
273
|
|
|
|
|
|
|
local $_ = shift; |
274
|
|
|
|
|
|
|
my $message_ref = shift; |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
my $rule_exists = 0; |
277
|
|
|
|
|
|
|
my $orig_value = $_; |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
foreach my $rule (@$rule_list) { |
280
|
|
|
|
|
|
|
if (!defined $rule || $rule eq '') { |
281
|
|
|
|
|
|
|
$trouble_level++; |
282
|
|
|
|
|
|
|
$fail_action->("Rules: rule for validation not set"); |
283
|
|
|
|
|
|
|
next # in case of fail action doesn't die |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
if ($rule) { |
287
|
|
|
|
|
|
|
my $special_rule = $special_rules->{$rule}; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
if ($special_rule) { |
290
|
|
|
|
|
|
|
$trouble_level++; |
291
|
|
|
|
|
|
|
$fail_action->("Rules: cannot call any special rule inside of rule '-And'\n"); |
292
|
|
|
|
|
|
|
next; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
validate ($subject_info, $rule, $_, $message_ref); |
296
|
|
|
|
|
|
|
$rule_exists = 1; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
$trouble_level++; |
301
|
|
|
|
|
|
|
$fail_action->("Rules: No rule found in list to be validated") unless $rule_exists; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
return $orig_value; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
}, |
306
|
|
|
|
|
|
|
-Or => { |
307
|
|
|
|
|
|
|
-value_position => 3, |
308
|
|
|
|
|
|
|
-code => sub { |
309
|
|
|
|
|
|
|
my $subject_info = shift || ''; |
310
|
|
|
|
|
|
|
my $rule_list = shift; |
311
|
|
|
|
|
|
|
local $_ = shift; |
312
|
|
|
|
|
|
|
my $message_ref = shift; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
my $rule_exists = 0; |
315
|
|
|
|
|
|
|
my $orig_value = $_; |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
foreach my $rule_info (@$rule_list) { |
318
|
|
|
|
|
|
|
if (!defined $rule_info || $rule_info eq '') { |
319
|
|
|
|
|
|
|
$trouble_level++; |
320
|
|
|
|
|
|
|
$fail_action->("Rules: rule for validation not set"); |
321
|
|
|
|
|
|
|
next # in case of fail action doesn't die |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
next unless $rule_info; |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
my $rule_ref = $rule_store->{$rule_info}; |
327
|
|
|
|
|
|
|
unless ($rule_ref) { |
328
|
|
|
|
|
|
|
my $special_rule = $special_rules->{$rule_info}; |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
if ($special_rule) { |
331
|
|
|
|
|
|
|
$trouble_level++; |
332
|
|
|
|
|
|
|
$fail_action->("Rules: cannot call any special rule inside of rule '-Or'\n"); |
333
|
|
|
|
|
|
|
next; |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
my $ref_type = ref ($rule_info); |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
unless ($ref_type) { |
339
|
|
|
|
|
|
|
$trouble_level++; |
340
|
|
|
|
|
|
|
$fail_action->("Rules: unknown rule '$rule_info' for validation"); |
341
|
|
|
|
|
|
|
next; # in case of fail action doesn't die |
342
|
|
|
|
|
|
|
} elsif ($ref_type eq 'HASH') { # given rule |
343
|
|
|
|
|
|
|
$rule_ref = $rule_info; |
344
|
|
|
|
|
|
|
# TODO: validate rule ... |
345
|
|
|
|
|
|
|
} elsif ($ref_type eq 'CODE') { # where condition for rule |
346
|
|
|
|
|
|
|
$rule_ref = { |
347
|
|
|
|
|
|
|
-where => $rule_info, |
348
|
|
|
|
|
|
|
-message => sub { "$_ does not match free defined rule" }, |
349
|
|
|
|
|
|
|
}; |
350
|
|
|
|
|
|
|
} else { |
351
|
|
|
|
|
|
|
$trouble_level++; |
352
|
|
|
|
|
|
|
$fail_action->("Rules: cannot handle ref type '$ref_type' of rule '$rule_info' for validation"); |
353
|
|
|
|
|
|
|
next; # in case of fail action doesn't die |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
if ($rule_ref) { |
358
|
|
|
|
|
|
|
my $test_message_ref = $message_ref || $rule_ref->{-message}; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
my $parent_is_valid = defined $rule_ref->{-as} |
361
|
|
|
|
|
|
|
? _check_parent_rules($rule_ref->{-as}, $_) |
362
|
|
|
|
|
|
|
: 1; |
363
|
|
|
|
|
|
|
return $orig_value if $parent_is_valid && $rule_ref->{-where}->(); |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
$rule_exists = 1; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
$trouble_level++; |
370
|
|
|
|
|
|
|
$fail_action->("Rules: No rule found in list to be validated") unless $rule_exists; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
my $result = _do_fail($subject_info, $message_ref || sub { "No rule matched of [".join(', ', @$rule_list)."]";}); |
373
|
|
|
|
|
|
|
return $result if defined $result; |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
return $orig_value; |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
}, |
378
|
|
|
|
|
|
|
-Enum => { |
379
|
|
|
|
|
|
|
-value_position => 3, |
380
|
|
|
|
|
|
|
-code => sub { |
381
|
|
|
|
|
|
|
my $subject_info = shift || ''; |
382
|
|
|
|
|
|
|
my $enum_ref = shift; |
383
|
|
|
|
|
|
|
local $_ = shift; |
384
|
|
|
|
|
|
|
my $message_ref = shift; |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
my $orig_value = $_; |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
my $arg_type = ref ($enum_ref); |
389
|
|
|
|
|
|
|
if ($arg_type eq 'ARRAY') { |
390
|
|
|
|
|
|
|
$enum_ref = { map {$_=> 1} @$enum_ref }; |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
elsif ($arg_type ne 'HASH') { |
393
|
|
|
|
|
|
|
_do_fail($subject_info, sub {"-Enum needs HASH_ref as second parameter";}); |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
unless (defined $_ && $enum_ref->{$_}) { |
397
|
|
|
|
|
|
|
my $result = _do_fail($subject_info, $message_ref || |
398
|
|
|
|
|
|
|
sub { "value $_ unknown, allowed values are: [ " |
399
|
|
|
|
|
|
|
.join (", ", sort (keys(%$enum_ref)))." ]"; } |
400
|
|
|
|
|
|
|
); |
401
|
|
|
|
|
|
|
return $result if defined $result; |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
return $orig_value; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
}, |
407
|
|
|
|
|
|
|
-Range => { |
408
|
|
|
|
|
|
|
-value_position => 4, |
409
|
|
|
|
|
|
|
-code => sub { |
410
|
|
|
|
|
|
|
my $subject_info = shift || ''; |
411
|
|
|
|
|
|
|
my $range_ref = shift; |
412
|
|
|
|
|
|
|
my $rule = shift; |
413
|
|
|
|
|
|
|
local $_ = shift; |
414
|
|
|
|
|
|
|
my $message_ref = shift; |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
my $wrong_call_message_sub_ref |
417
|
|
|
|
|
|
|
= sub { "-Range needs ARRAY_ref containing two values [min max] as second parameter" }; |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
my $orig_value = $_; |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
unless (ref($range_ref) eq 'ARRAY') { |
422
|
|
|
|
|
|
|
_do_fail($subject_info, $wrong_call_message_sub_ref); |
423
|
|
|
|
|
|
|
return $orig_value; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
unless (scalar @$range_ref == 2) { |
427
|
|
|
|
|
|
|
_do_fail($subject_info, $wrong_call_message_sub_ref); |
428
|
|
|
|
|
|
|
return $orig_value; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
my ($min, $max) = @$range_ref; |
432
|
|
|
|
|
|
|
if ($min > $max) { |
433
|
|
|
|
|
|
|
_do_fail($subject_info, sub { "(min) $min > $max (max) in range definition"; }); |
434
|
|
|
|
|
|
|
return $orig_value; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
# type check by is_valid to return here if fails |
438
|
|
|
|
|
|
|
my @messages; |
439
|
|
|
|
|
|
|
my $is_valid; |
440
|
|
|
|
|
|
|
{ |
441
|
|
|
|
|
|
|
local ($message_store) = []; |
442
|
|
|
|
|
|
|
$is_valid = is_valid ($subject_info, $rule, $_, $message_ref); |
443
|
|
|
|
|
|
|
@messages = @{validation_messages()}; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
unless ($is_valid) { |
447
|
|
|
|
|
|
|
my $message = join ("\n", @messages); |
448
|
|
|
|
|
|
|
push (@$message_store, $message) if $message_store; |
449
|
|
|
|
|
|
|
$trouble_level++; |
450
|
|
|
|
|
|
|
my $result = $fail_action->($message); |
451
|
|
|
|
|
|
|
return $result if defined $result; |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
return $orig_value; |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
unless ($min <= $_ && $_<= $max) { |
457
|
|
|
|
|
|
|
my $result = _do_fail($subject_info, sub {"value $_ is out of range [$min,$max]"}); |
458
|
|
|
|
|
|
|
return $result if defined $result; |
459
|
|
|
|
|
|
|
return $orig_value; |
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
return $orig_value; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
}, |
465
|
|
|
|
|
|
|
-RefEmpty => { |
466
|
|
|
|
|
|
|
-value_position => 3, |
467
|
|
|
|
|
|
|
-code => sub { |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
my $subject_info = shift || ''; |
470
|
|
|
|
|
|
|
local $_ = shift; |
471
|
|
|
|
|
|
|
my $message_ref = shift; |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
my $content_ref = _ref_empty_check($subject_info, $_, $message_ref); |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
return undef unless defined $content_ref; |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
my $count_results = scalar @$content_ref; |
478
|
|
|
|
|
|
|
return 0 unless $count_results; |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
_do_fail($subject_info, sub { "Should be empty, but contains $count_results entries: [ ". |
481
|
|
|
|
|
|
|
join (", ", @$content_ref)." ];" }); |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
return $count_results; |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
}, |
486
|
|
|
|
|
|
|
}; |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
489
|
|
|
|
|
|
|
# |
490
|
|
|
|
|
|
|
# internal Methods |
491
|
|
|
|
|
|
|
# |
492
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
sub _handle_enum_explained { |
495
|
2
|
|
|
2
|
|
4
|
my $transform_key_ref = shift; |
496
|
2
|
|
|
|
|
3
|
my $transformed_text = shift; |
497
|
2
|
|
|
|
|
2
|
my $rule_name = shift; |
498
|
2
|
|
|
|
|
3
|
my @enum_args; |
499
|
|
|
|
|
|
|
my @enums_list; |
500
|
0
|
|
|
|
|
0
|
my %enums; |
501
|
|
|
|
|
|
|
|
502
|
2
|
|
|
|
|
4
|
foreach my $arg (@_) { |
503
|
24
|
100
|
66
|
|
|
74
|
if ($arg eq 1 or $arg eq 0) { |
504
|
|
|
|
|
|
|
# arg is complete |
505
|
6
|
|
|
|
|
7
|
my $last_idx = $#enum_args; |
506
|
|
|
|
|
|
|
|
507
|
6
|
50
|
|
|
|
12
|
if ($last_idx < 1) { |
508
|
0
|
|
|
|
|
0
|
$trouble_level++; |
509
|
0
|
|
|
|
|
0
|
$fail_action->("Rules: not enough configuration values for enum '$enum_args[0]'"); |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
|
512
|
6
|
|
|
|
|
7
|
my $explanation = $enum_args[$last_idx]; |
513
|
6
|
100
|
|
|
|
13
|
map { my $key = $transform_key_ref ? $transform_key_ref->($_): $_; |
|
12
|
|
|
|
|
23
|
|
514
|
12
|
|
|
|
|
22
|
$enums{$key} = $explanation; |
515
|
12
|
|
|
|
|
19
|
push (@enums_list, $key); |
516
|
|
|
|
|
|
|
} @enum_args[0..--$last_idx]; |
517
|
6
|
|
|
|
|
13
|
@enum_args = (); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
else { |
520
|
18
|
|
|
|
|
19
|
push (@enum_args, $arg); |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
my $validation_sub_ref = $transform_key_ref |
525
|
3
|
50
|
|
3
|
|
15
|
? sub { defined $_ && defined $enums{$transform_key_ref->($_)} } |
526
|
2
|
50
|
|
3
|
|
8
|
: sub { defined $_ && defined $enums{$_} }; |
|
3
|
100
|
|
|
|
25
|
|
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
return ($rule_name, |
529
|
|
|
|
|
|
|
-where => $validation_sub_ref, |
530
|
|
|
|
|
|
|
-enum => \%enums, |
531
|
2
|
|
|
2
|
|
16
|
-message => sub { "$rule_name: value $_ unknown, allowed values$transformed_text ". |
532
|
|
|
|
|
|
|
"are: [ ".join (", ", @enums_list)." ]" } |
533
|
2
|
|
|
|
|
19
|
); |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
sub _check_parent_rules { |
537
|
214
|
|
|
214
|
|
350
|
my $rule_name = shift; |
538
|
214
|
|
|
|
|
299
|
local $_ = shift; |
539
|
|
|
|
|
|
|
|
540
|
214
|
|
|
|
|
429
|
my $orig_value = $_; |
541
|
|
|
|
|
|
|
|
542
|
214
|
|
|
|
|
410
|
my $rule_ref = $rule_store->{$rule_name}; |
543
|
|
|
|
|
|
|
|
544
|
214
|
100
|
|
|
|
489
|
unless ($rule_ref) { |
545
|
1
|
|
|
|
|
3
|
$trouble_level++; |
546
|
1
|
|
|
|
|
5
|
$fail_action->("Rules: unknown rule '$rule_name' for validation"); |
547
|
0
|
|
|
|
|
0
|
return 0; # in case of fail action doesn't die |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
213
|
100
|
|
|
|
521
|
if (defined $rule_ref->{-as}) { |
551
|
64
|
50
|
|
|
|
172
|
return 0 unless _check_parent_rules($rule_ref->{-as}, $_); |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
|
554
|
213
|
|
|
|
|
537
|
return $rule_ref->{-where}->(); |
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
sub _ref_empty_check { |
558
|
5
|
|
50
|
5
|
|
13
|
my $subject_info = shift || ''; |
559
|
5
|
|
|
|
|
7
|
local $_ = shift; |
560
|
5
|
|
|
|
|
6
|
my $message_ref = shift; |
561
|
|
|
|
|
|
|
|
562
|
5
|
|
|
|
|
9
|
my $ref_type = ref($_); |
563
|
|
|
|
|
|
|
|
564
|
5
|
100
|
|
|
|
12
|
unless ($ref_type) { |
565
|
2
|
|
|
2
|
|
18
|
_do_fail($subject_info, sub { "Not a reference: $_" }); |
|
2
|
|
|
|
|
7
|
|
566
|
0
|
|
|
|
|
0
|
return undef; |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
3
|
|
|
|
|
6
|
my $get_contents_ref = $get_content_subs->{$ref_type}; |
570
|
|
|
|
|
|
|
|
571
|
3
|
100
|
|
|
|
9
|
unless ($get_contents_ref) { |
572
|
1
|
|
|
1
|
|
6
|
_do_fail($subject_info, sub { "could not check, if $ref_type is empty" }); |
|
1
|
|
|
|
|
4
|
|
573
|
0
|
|
|
|
|
0
|
return undef; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
2
|
|
|
|
|
6
|
return $get_contents_ref->(); |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
sub _do_fail { |
580
|
24
|
|
|
24
|
|
40
|
my $subject_info = shift; |
581
|
24
|
|
|
|
|
34
|
my $message_ref = shift; |
582
|
|
|
|
|
|
|
|
583
|
24
|
|
|
|
|
27
|
$trouble_level++; |
584
|
|
|
|
|
|
|
|
585
|
24
|
100
|
|
|
|
119
|
$_ = defined ($_) ? "'$_'" : ''; |
586
|
|
|
|
|
|
|
|
587
|
24
|
|
|
|
|
59
|
my $message = $get_caller_info->()."($subject_info): ".$message_ref->(); |
588
|
24
|
50
|
|
|
|
70
|
push (@$message_store, $message) if $message_store; |
589
|
|
|
|
|
|
|
|
590
|
24
|
|
|
|
|
50
|
return $fail_action->($message); |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
594
|
|
|
|
|
|
|
# |
595
|
|
|
|
|
|
|
# API Methods |
596
|
|
|
|
|
|
|
# |
597
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
sub _init_run_API { |
600
|
1
|
|
|
1
|
|
4
|
*npar = *named_parameter; |
601
|
|
|
|
|
|
|
|
602
|
1
|
|
|
|
|
3
|
*parameter = *_do_validate; |
603
|
1
|
|
|
|
|
3
|
*par = *parameter; |
604
|
|
|
|
|
|
|
|
605
|
1
|
|
|
|
|
3
|
*validate = *_do_validate; |
606
|
|
|
|
|
|
|
|
607
|
1
|
|
|
|
|
3
|
*p_end = *parameters_end; |
608
|
|
|
|
|
|
|
|
609
|
1
|
|
|
|
|
2
|
*g_t = *greater_than; |
610
|
1
|
|
|
|
|
3
|
*g_e = *greater_equal; |
611
|
1
|
|
|
|
|
4
|
*l_t = *less_than; |
612
|
1
|
|
|
|
|
2
|
*l_e = *less_equal; |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
sub convert_to_named_params { |
617
|
17
|
|
|
17
|
0
|
104
|
my $array_ref = validate (args => ArrayRef => shift); |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
validate (arg_count => Even => scalar @$array_ref => |
620
|
16
|
|
|
1
|
|
65
|
sub { "Even number of args needed to build a hash, but arg-count = $_" }); |
|
1
|
|
|
|
|
4
|
|
621
|
15
|
|
|
|
|
80
|
return @$array_ref; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
sub parameters_end { |
625
|
12
|
|
|
12
|
0
|
41
|
my $container_ref = par (container_ref => -Or => [HashRef => 'ArrayRef'] => shift); |
626
|
12
|
|
50
|
|
|
31
|
my $message_text = par (message_text => Scalar => shift) || "extra parameters found"; |
627
|
|
|
|
|
|
|
|
628
|
12
|
|
|
|
|
18
|
my $container_type = ref ($container_ref); |
629
|
12
|
50
|
|
|
|
31
|
if ($container_type eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
630
|
0
|
|
|
0
|
|
0
|
validate (parameters => sub { scalar @$container_ref == 0 } => $container_ref => sub { "$message_text: [ '".join ("', '", @$container_ref)."' ]"; }); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
631
|
0
|
|
|
|
|
0
|
return scalar @$container_ref; |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
elsif ($container_type eq 'HASH') { |
634
|
12
|
|
|
|
|
24
|
my @arg_names = keys %$container_ref; |
635
|
12
|
|
|
12
|
|
73
|
validate (parameters => sub { scalar @arg_names == 0 } => $container_ref => sub { "$message_text: [ '".join ("', '", @arg_names)."' ]"; }); |
|
12
|
|
|
|
|
43
|
|
|
0
|
|
|
|
|
0
|
|
636
|
12
|
|
|
|
|
42
|
return scalar @arg_names; |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
0
|
|
|
0
|
|
0
|
_do_fail("parameters_end()", sub { "unknown reference type $container_ref" }); |
|
0
|
|
|
|
|
0
|
|
640
|
0
|
|
|
|
|
0
|
return -1; |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
644
|
|
|
|
|
|
|
# |
645
|
|
|
|
|
|
|
# Messages and Validation Mode |
646
|
|
|
|
|
|
|
# |
647
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
sub validation_trouble { |
650
|
5
|
|
50
|
5
|
0
|
1422
|
my $trouble_accepted = shift || 0; |
651
|
5
|
50
|
|
|
|
35
|
return $trouble_level > $trouble_accepted ? $trouble_level: 0; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
sub validation_messages { |
655
|
38
|
|
100
|
38
|
0
|
166
|
my $mode = shift || ''; |
656
|
|
|
|
|
|
|
|
657
|
38
|
100
|
66
|
|
|
298
|
return $message_store if !$message_store || !$mode || $mode ne '-clear'; |
|
|
|
66
|
|
|
|
|
658
|
|
|
|
|
|
|
|
659
|
2
|
|
|
|
|
6
|
my @messages = @$message_store; |
660
|
2
|
|
|
|
|
4
|
@$message_store = (); |
661
|
2
|
|
|
|
|
15
|
return \@messages; |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
sub prepare_validation_mode { |
665
|
7
|
|
|
7
|
0
|
156
|
my $mode = lc(shift); |
666
|
|
|
|
|
|
|
|
667
|
7
|
|
|
|
|
13
|
my $new_fail_action = $fail_action; |
668
|
7
|
|
|
|
|
12
|
my $new_off = $off; |
669
|
|
|
|
|
|
|
|
670
|
7
|
50
|
|
|
|
49
|
unless (is_valid(mode => -Enum => [ qw (die warn silent off) ] => $mode)) { |
671
|
0
|
|
|
|
|
0
|
$trouble_level++; |
672
|
0
|
|
|
|
|
0
|
croak "prepare_validation_mode(): unknown mode for Scalar::Validation selected: '$mode'"; |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
# print "#### Select validation mode: $mode\n"; |
676
|
|
|
|
|
|
|
|
677
|
7
|
50
|
|
|
|
41
|
if ($mode eq 'die') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
678
|
0
|
|
|
|
|
0
|
$new_fail_action = $croak_sub; |
679
|
0
|
|
|
|
|
0
|
$new_off = 0; |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
elsif ($mode eq 'warn') { |
682
|
2
|
|
|
2
|
|
7
|
$new_fail_action = sub { carp "Warning: ", @_; return undef; }; |
|
2
|
|
|
|
|
31
|
|
|
2
|
|
|
|
|
2337
|
|
683
|
2
|
|
|
|
|
4
|
$new_off = 0; |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
elsif ($mode eq 'silent') { |
686
|
3
|
|
|
2
|
|
21
|
$new_fail_action = sub { return undef; }; |
|
2
|
|
|
|
|
4
|
|
687
|
3
|
|
|
|
|
5
|
$new_off = 0; |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
elsif ($mode eq 'off') { |
690
|
2
|
|
|
0
|
|
11
|
$new_fail_action = sub { return undef; }; |
|
0
|
|
|
|
|
0
|
|
691
|
2
|
|
|
|
|
4
|
$new_off = 1; |
692
|
|
|
|
|
|
|
} else { |
693
|
|
|
|
|
|
|
# shouldn't be reached, just to be sure |
694
|
0
|
|
|
|
|
0
|
$trouble_level++; |
695
|
0
|
|
|
|
|
0
|
$fail_action->("prepare_validation_mode(): unknown validation mode $mode used"); |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
7
|
|
|
|
|
28
|
return $new_fail_action, $new_off; |
699
|
|
|
|
|
|
|
} |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
702
|
|
|
|
|
|
|
# |
703
|
|
|
|
|
|
|
# Rules |
704
|
|
|
|
|
|
|
# |
705
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
sub get_rules { |
708
|
0
|
|
|
0
|
0
|
0
|
return $rule_store; |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
sub rule_known { |
712
|
2
|
|
|
2
|
0
|
4
|
my $rule = par (rule => Filled => shift, sub { "rule to search not set" }); |
|
21
|
|
|
21
|
|
127
|
|
713
|
|
|
|
|
|
|
|
714
|
19
|
100
|
|
|
|
185
|
return $rule_store->{$rule} ? $rule : ''; |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
sub declare_rule { |
718
|
2
|
|
|
2
|
1
|
5
|
my $rule_name = par (rule => Filled => shift, sub { "rule to declare not set" }); |
|
18
|
|
|
18
|
|
280
|
|
719
|
16
|
100
|
|
|
|
53
|
if (rule_known($rule_name)) { $fail_action->("rule '$rule_name': already defined"); } |
|
1
|
|
|
|
|
4
|
|
720
|
|
|
|
|
|
|
|
721
|
15
|
|
|
|
|
41
|
my %call_options = convert_to_named_params \@_; |
722
|
15
|
|
|
|
|
21
|
my %rule_options; |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
$rule_options{-where} = npar (-where => CodeRef => \%call_options |
725
|
15
|
|
|
3
|
|
76
|
=> sub { "rule '$rule_name': where condition"._defined_or_not_message($_, " is not a code reference: $_");}); |
|
3
|
|
|
|
|
15
|
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
$rule_options{-message} = npar (-message => -Optional => CodeRef => \%call_options |
728
|
0
|
|
|
0
|
|
0
|
=> sub { "rule '$rule_name': message"._defined_or_not_message($_, " is not a code reference: $_");}) |
729
|
12
|
|
100
|
1
|
|
87
|
|| sub { "Value $_ is not valid for rule '$rule_name'" }; |
|
1
|
|
|
|
|
6
|
|
730
|
|
|
|
|
|
|
|
731
|
12
|
|
|
|
|
65
|
$rule_options{-as} = npar (-as => -Optional => String => \%call_options); |
732
|
12
|
|
|
|
|
41
|
$rule_options{-enum} = npar (-enum => -Optional => HashRef => \%call_options); |
733
|
12
|
|
33
|
|
|
38
|
$rule_options{-name} = npar (-name => -Optional => String => \%call_options) || $rule_name; |
734
|
12
|
|
33
|
|
|
41
|
$rule_options{-description } = npar (-description => -Optional => String => \%call_options) || "Rule $rule_name"; |
735
|
|
|
|
|
|
|
|
736
|
12
|
|
|
|
|
31
|
parameters_end (\%call_options); |
737
|
|
|
|
|
|
|
|
738
|
12
|
|
|
|
|
27
|
$rule_store->{$rule_name} = \%rule_options; |
739
|
|
|
|
|
|
|
|
740
|
12
|
|
|
|
|
65
|
return $rule_name; |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
sub delete_rule { |
744
|
0
|
|
|
0
|
1
|
0
|
my $rule_name = par (rule => Filled => shift, sub { "rule to delete not set" }); |
|
2
|
|
|
2
|
|
10
|
|
745
|
|
|
|
|
|
|
|
746
|
0
|
|
|
0
|
|
0
|
validate (delete_rule => Defined => delete $rule_store->{$rule_name} |
747
|
2
|
|
|
|
|
13
|
=> sub {"no rule $rule_name found to delete"}); |
748
|
2
|
|
|
|
|
19
|
return $rule_name; |
749
|
|
|
|
|
|
|
} |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
sub replace_rule { |
752
|
0
|
|
|
0
|
1
|
0
|
my $rule_name = par (rule => Filled => shift, sub { "rule to replace not set" }); |
|
1
|
|
|
1
|
|
5
|
|
753
|
|
|
|
|
|
|
|
754
|
1
|
|
|
|
|
4
|
return declare_rule(delete_rule($rule_name), @_); |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
# $_ is set to string '' in message part, if it was not defined |
758
|
|
|
|
|
|
|
sub _defined_or_not_message { |
759
|
3
|
100
|
|
3
|
|
13
|
return " is missing" if '' eq shift; |
760
|
2
|
|
|
|
|
6
|
return shift; |
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
764
|
|
|
|
|
|
|
# |
765
|
|
|
|
|
|
|
# Dynamic rules |
766
|
|
|
|
|
|
|
# |
767
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
# --- Enum --------------------------------------------------------------------------- |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
sub Enum { |
772
|
1
|
|
|
1
|
0
|
4
|
my $rule_name = shift; |
773
|
1
|
|
|
|
|
3
|
my %enums = map { $_ => 1 } @_; |
|
6
|
|
|
|
|
14
|
|
774
|
1
|
|
|
|
|
3
|
my @enums_list = @_; |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
return ($rule_name, |
777
|
3
|
50
|
|
3
|
|
28
|
-where => sub { defined $_ && defined $enums{$_} }, |
778
|
|
|
|
|
|
|
-enum => \%enums, |
779
|
1
|
|
|
1
|
|
9
|
-message => sub { "$rule_name: value $_ unknown, allowed values are: [ ".join (", ", @enums_list)." ]" } |
780
|
1
|
|
|
|
|
12
|
); |
781
|
|
|
|
|
|
|
} |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
sub enum { |
784
|
1
|
|
|
1
|
0
|
3
|
my $rule_name = shift; |
785
|
1
|
|
|
|
|
3
|
my %enums = map { lc($_) => 1 } @_; |
|
6
|
|
|
|
|
18
|
|
786
|
1
|
|
|
|
|
3
|
my @enums_list = map { lc($_) } @_; |
|
6
|
|
|
|
|
10
|
|
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
return ($rule_name, |
789
|
3
|
50
|
|
3
|
|
30
|
-where => sub { defined $_ && defined $enums{lc($_)} }, |
790
|
|
|
|
|
|
|
-enum => \%enums, |
791
|
1
|
|
|
1
|
|
9
|
-message => sub { "$rule_name: value $_ unknown, allowed values (transformed to lower case) are: [ ".join (", ", @enums_list)." ]" } |
792
|
1
|
|
|
|
|
11
|
); |
793
|
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
sub Enum_explained { |
796
|
1
|
|
|
1
|
0
|
5
|
_handle_enum_explained(undef, "", @_); |
797
|
|
|
|
|
|
|
} |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
sub enum_explained { |
800
|
9
|
|
|
9
|
0
|
29
|
_handle_enum_explained(sub { lc($_[0])}, " (transformed to lower case)", @_); |
|
1
|
|
|
1
|
|
488
|
|
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# --- numerical compare --------------------------------------------------------------------------- |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
sub greater_than { |
806
|
4
|
|
|
4
|
0
|
9
|
my $limit = shift; |
807
|
4
|
|
|
|
|
10
|
my $type = shift; |
808
|
|
|
|
|
|
|
return ({ -as => $type, |
809
|
4
|
|
|
4
|
|
22
|
-where => sub { $_ > $limit }, |
810
|
2
|
|
|
2
|
|
11
|
-message => sub { "$_ > $limit failed. Value is not of type $type or not greater than limit."}, |
811
|
|
|
|
|
|
|
}, |
812
|
4
|
|
|
|
|
48
|
@_); |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
sub greater_equal { |
816
|
6
|
|
|
6
|
0
|
10
|
my $limit = shift; |
817
|
6
|
|
|
|
|
11
|
my $type = shift; |
818
|
|
|
|
|
|
|
return ({ -as => $type, |
819
|
6
|
|
|
6
|
|
26
|
-where => sub { $_ >= $limit }, |
820
|
2
|
|
|
2
|
|
9
|
-message => sub { "$_ >= $limit failed. Value is not of type $type or not greater than limit."}, |
821
|
|
|
|
|
|
|
}, |
822
|
6
|
|
|
|
|
70
|
@_); |
823
|
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
sub equal_to { |
826
|
3
|
|
|
3
|
0
|
6
|
my $compare = shift; |
827
|
3
|
|
|
|
|
6
|
my $type = shift; |
828
|
3
|
100
|
|
|
|
9
|
if ($type eq 'String') { |
829
|
|
|
|
|
|
|
return ({ -as => $type, |
830
|
1
|
|
|
1
|
|
5
|
-where => sub { $_ eq $compare }, |
831
|
0
|
|
|
0
|
|
0
|
-message => sub { "$_ eq $compare failed. Value is not of type $type or different."}, |
832
|
|
|
|
|
|
|
}, |
833
|
1
|
|
|
|
|
13
|
@_); |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
return ({ -as => $type, |
837
|
2
|
|
|
2
|
|
8
|
-where => sub { $_ == $compare }, |
838
|
0
|
|
|
0
|
|
0
|
-message => sub { "$_ == $compare failed. Value is not of type $type or different."}, |
839
|
|
|
|
|
|
|
}, |
840
|
2
|
|
|
|
|
25
|
@_); |
841
|
|
|
|
|
|
|
} |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
sub less_than { |
844
|
4
|
|
|
4
|
0
|
7
|
my $limit = shift; |
845
|
4
|
|
|
|
|
8
|
my $type = shift; |
846
|
|
|
|
|
|
|
return ({ -as => $type, |
847
|
4
|
|
|
4
|
|
114
|
-where => sub { $_ < $limit }, |
848
|
2
|
|
|
2
|
|
8
|
-message => sub { "$_ < $limit failed. Value is not of type $type or not less than limit."}, |
849
|
|
|
|
|
|
|
}, |
850
|
4
|
|
|
|
|
39
|
@_); |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
sub less_equal { |
854
|
6
|
|
|
6
|
0
|
12
|
my $limit = shift; |
855
|
6
|
|
|
|
|
8
|
my $type = shift; |
856
|
|
|
|
|
|
|
return ({ -as => $type, |
857
|
6
|
|
|
6
|
|
26
|
-where => sub { $_ <= $limit }, |
858
|
2
|
|
|
2
|
|
8
|
-message => sub { "$_ <= $limit failed. Value is not of type $type or not less than limit."}, |
859
|
|
|
|
|
|
|
}, |
860
|
6
|
|
|
|
|
67
|
@_); |
861
|
|
|
|
|
|
|
} |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# --- ISA --------------------------------------------------------------------------- |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
sub is_a { |
866
|
8
|
|
|
8
|
0
|
66
|
my $type = shift; |
867
|
|
|
|
|
|
|
return ({ -as => 'Class', |
868
|
2
|
|
|
2
|
|
35
|
-where => sub { return $_->isa($type) }, |
869
|
7
|
|
|
7
|
|
25
|
-message => sub { "$_ is not of class $type or derived from it."}, |
870
|
|
|
|
|
|
|
}, |
871
|
8
|
|
|
|
|
259
|
@_); |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
875
|
|
|
|
|
|
|
# |
876
|
|
|
|
|
|
|
# Validation |
877
|
|
|
|
|
|
|
# |
878
|
|
|
|
|
|
|
# ------------------------------------------------------------------------------ |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
# --- helpful for tests ------------------------------------------------ |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
sub is_valid { |
883
|
249
|
|
|
249
|
1
|
326
|
my $valid = 1; |
884
|
|
|
|
|
|
|
|
885
|
249
|
|
|
67
|
|
755
|
local $fail_action = sub { $valid = 0 }; |
|
67
|
|
|
|
|
117
|
|
886
|
249
|
|
|
|
|
319
|
local $trouble_level = 0; # not to rise trouble level |
887
|
|
|
|
|
|
|
|
888
|
249
|
|
|
|
|
479
|
validate(@_); |
889
|
|
|
|
|
|
|
|
890
|
249
|
|
|
|
|
1212
|
return $valid; |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
# --- return value if valid --------------- |
894
|
|
|
|
|
|
|
# --- return corrected value if invalid --------------- |
895
|
|
|
|
|
|
|
sub validate_and_correct { |
896
|
8
|
|
|
8
|
1
|
16
|
my ($validation_options_ref, # options for validate |
897
|
|
|
|
|
|
|
$options_ref |
898
|
|
|
|
|
|
|
) = @_; |
899
|
|
|
|
|
|
|
|
900
|
8
|
|
|
|
|
12
|
my $correction_action = $options_ref->{-correction}; # action that does corrections in value |
901
|
8
|
100
|
|
|
|
21
|
unless ( defined $validation_options_ref->[-1]) { |
902
|
3
|
50
|
|
|
|
11
|
$validation_options_ref->[-1] = $options_ref->{-default} if exists $options_ref->{-default}; |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
|
905
|
8
|
100
|
|
|
|
16
|
if ($correction_action) { |
906
|
|
|
|
|
|
|
local ($fail_action) = sub { |
907
|
5
|
|
|
5
|
|
15
|
s/^'//o; |
908
|
5
|
|
|
|
|
13
|
s/'$//o; |
909
|
5
|
|
|
|
|
13
|
$correction_action->($_); |
910
|
6
|
|
|
|
|
18
|
}; |
911
|
6
|
|
|
|
|
15
|
return validate(@$validation_options_ref); |
912
|
|
|
|
|
|
|
} |
913
|
2
|
|
|
|
|
3
|
return validate(@$validation_options_ref); |
914
|
|
|
|
|
|
|
} |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
# --- don't name key twice, deletes validated values out of hash ------------------------- |
917
|
|
|
|
|
|
|
# named_parameter |
918
|
|
|
|
|
|
|
sub named_parameter { |
919
|
78
|
|
|
78
|
1
|
94
|
my $first_arg = shift; |
920
|
78
|
|
|
|
|
76
|
my $hash_ref; |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
my $msg_ref; |
923
|
0
|
|
|
|
|
0
|
my $key; |
924
|
0
|
|
|
|
|
0
|
my $option_args_ref; |
925
|
|
|
|
|
|
|
|
926
|
78
|
|
|
|
|
98
|
my $args_ref = \@_; |
927
|
|
|
|
|
|
|
|
928
|
78
|
100
|
|
|
|
142
|
unless (is_valid(key => Scalar => $first_arg)) { |
929
|
2
|
|
|
|
|
5
|
$args_ref = validate (validation_args => ArrayRef => $first_arg); |
930
|
2
|
|
|
|
|
4
|
$key = shift @$args_ref; |
931
|
2
|
|
|
|
|
4
|
$option_args_ref = shift; |
932
|
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
else { |
934
|
76
|
|
|
|
|
98
|
$key = $first_arg; |
935
|
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
|
|
937
|
78
|
|
|
|
|
116
|
$key = validate (key => Scalar => $key); |
938
|
|
|
|
|
|
|
|
939
|
78
|
|
|
|
|
105
|
$hash_ref = pop @$args_ref; |
940
|
|
|
|
|
|
|
|
941
|
78
|
100
|
|
|
|
127
|
unless (is_valid(option_ref => HashRef => $hash_ref)) { |
942
|
27
|
|
|
|
|
48
|
$msg_ref = validate (message_ref => CodeRef => $hash_ref); |
943
|
27
|
|
|
|
|
49
|
$hash_ref = validate (option_ref => HashRef => pop @$args_ref); |
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
|
946
|
78
|
|
|
|
|
122
|
my $value = delete $hash_ref->{$key}; |
947
|
|
|
|
|
|
|
|
948
|
78
|
100
|
|
|
|
147
|
unless (defined $value) { |
949
|
43
|
50
|
|
|
|
75
|
if ($option_args_ref) { |
950
|
0
|
|
|
|
|
0
|
$value = $option_args_ref->{-default}; |
951
|
0
|
|
|
|
|
0
|
print "used default $key => '$value'\n"; |
952
|
|
|
|
|
|
|
# print $option_args_ref->{-description}."\n"; |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
} |
955
|
|
|
|
|
|
|
|
956
|
78
|
|
|
|
|
127
|
return validate ($key, @$args_ref, $value, $msg_ref); |
957
|
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
# --- return value if valid --------------- |
960
|
|
|
|
|
|
|
# --- call $fail_action if invalid --------------- |
961
|
|
|
|
|
|
|
sub _do_validate { |
962
|
782
|
100
|
|
782
|
|
3630
|
if ($off) { |
963
|
6
|
|
|
|
|
9
|
my $value_pos = 2; |
964
|
6
|
100
|
|
|
|
27
|
$value_pos = $special_rules->{$_[1]}->{-value_position} if $special_rules->{$_[1]}; |
965
|
6
|
100
|
|
|
|
22
|
return $_[$value_pos] if $value_pos >= 0; |
966
|
|
|
|
|
|
|
} |
967
|
|
|
|
|
|
|
|
968
|
781
|
|
100
|
|
|
1662
|
my $subject_info = shift || ''; |
969
|
781
|
|
|
|
|
1697
|
my $rule_info = shift; |
970
|
|
|
|
|
|
|
|
971
|
781
|
50
|
|
|
|
1386
|
unless ($rule_info) { |
972
|
0
|
|
|
|
|
0
|
$trouble_level++; |
973
|
0
|
|
|
|
|
0
|
$fail_action->("rule for validation not set"); |
974
|
0
|
|
|
|
|
0
|
return $_; # in case of fail action doesn't die |
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
|
977
|
781
|
|
|
|
|
1254
|
my $rule_ref = $rule_store->{$rule_info}; |
978
|
|
|
|
|
|
|
|
979
|
781
|
100
|
|
|
|
1254
|
unless ($rule_ref) { |
980
|
219
|
|
|
|
|
538
|
my $special_rule = $special_rules->{$rule_info}->{-code}; |
981
|
|
|
|
|
|
|
|
982
|
219
|
100
|
|
|
|
665
|
return $special_rule->($subject_info, @_) if $special_rule; |
983
|
|
|
|
|
|
|
|
984
|
51
|
|
|
|
|
70
|
my $ref_type = ref ($rule_info); |
985
|
|
|
|
|
|
|
|
986
|
51
|
100
|
|
|
|
354
|
unless ($ref_type) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
987
|
2
|
|
|
|
|
4
|
$trouble_level++; |
988
|
2
|
|
|
|
|
12
|
$fail_action->("unknown rule '$rule_info' for validation"); |
989
|
0
|
|
|
|
|
0
|
return shift; # in case of fail action doesn't die |
990
|
|
|
|
|
|
|
} |
991
|
|
|
|
|
|
|
elsif ($ref_type eq 'HASH') { # given rule |
992
|
34
|
|
|
|
|
60
|
$rule_ref = $rule_info; |
993
|
|
|
|
|
|
|
# TODO: validate rule ... |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
elsif ($ref_type eq 'CODE') { # where condition for rule |
996
|
|
|
|
|
|
|
$rule_ref = { |
997
|
|
|
|
|
|
|
-where => $rule_info, |
998
|
2
|
|
|
2
|
|
10
|
-message => sub { "$_ does not match free defined rule" }, |
999
|
15
|
|
|
|
|
91
|
}; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
else { |
1002
|
0
|
|
|
|
|
0
|
$trouble_level++; |
1003
|
0
|
|
|
|
|
0
|
$fail_action->("Rules: cannot handle ref type '$ref_type' of rule '$rule_info' for validation"); |
1004
|
0
|
|
|
|
|
0
|
return shift; # in case of fail action doesn't die |
1005
|
|
|
|
|
|
|
} |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
611
|
|
|
|
|
855
|
local $_ = shift; |
1009
|
611
|
|
|
|
|
651
|
my $message_ref = shift; |
1010
|
|
|
|
|
|
|
|
1011
|
611
|
|
|
|
|
616
|
my $orig_value = $_; |
1012
|
611
|
|
66
|
|
|
2216
|
my $test_message_ref = $message_ref || $rule_ref->{-message}; |
1013
|
|
|
|
|
|
|
|
1014
|
611
|
100
|
|
|
|
1472
|
my $parent_is_valid = defined $rule_ref->{-as} |
1015
|
|
|
|
|
|
|
? _check_parent_rules($rule_ref->{-as}, $_) |
1016
|
|
|
|
|
|
|
: 1; |
1017
|
|
|
|
|
|
|
|
1018
|
610
|
100
|
100
|
|
|
1893
|
unless ($parent_is_valid && $rule_ref->{-where}->()) { |
1019
|
104
|
100
|
|
|
|
352
|
$_ = defined ($_) ? "'$_'" : ''; |
1020
|
104
|
|
|
|
|
171
|
my $message = $get_caller_info->()."($subject_info): ".$test_message_ref->(); |
1021
|
104
|
100
|
|
|
|
292
|
push (@$message_store, $message) if $message_store; |
1022
|
104
|
|
|
|
|
104
|
$trouble_level++; |
1023
|
104
|
|
|
|
|
196
|
my $result = $fail_action->($message); |
1024
|
63
|
100
|
|
|
|
256
|
return $result if defined $result; |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
508
|
|
|
|
|
1549
|
return $orig_value; |
1028
|
|
|
|
|
|
|
} |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
1; |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
__END__ |