line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
=head1 NAME |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
Declare::Constraints::Simple::Library::Base - Library Base Class |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=cut |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package Declare::Constraints::Simple::Library::Base; |
8
|
13
|
|
|
13
|
|
42739
|
use warnings; |
|
13
|
|
|
|
|
29
|
|
|
13
|
|
|
|
|
583
|
|
9
|
13
|
|
|
13
|
|
197
|
use strict; |
|
13
|
|
|
|
|
30
|
|
|
13
|
|
|
|
|
441
|
|
10
|
|
|
|
|
|
|
|
11
|
13
|
|
|
13
|
|
62
|
use aliased 'Declare::Constraints::Simple::Result'; |
|
13
|
|
|
|
|
21
|
|
|
13
|
|
|
|
|
107
|
|
12
|
|
|
|
|
|
|
|
13
|
13
|
|
|
13
|
|
1430
|
use Carp::Clan qw(^Declare::Constraints::Simple); |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
119
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $FAIL_MESSAGE_DEFAULT = 'Validation Error'; |
16
|
|
|
|
|
|
|
our $FAIL_MESSAGE = ''; |
17
|
|
|
|
|
|
|
our $FAIL_INFO; |
18
|
|
|
|
|
|
|
our %SCOPES; |
19
|
|
|
|
|
|
|
|
20
|
13
|
|
|
13
|
|
2874
|
use base 'Declare::Constraints::Simple::Library::Exportable'; |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
8002
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 SYNOPSIS |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
package My::Constraint::Library; |
25
|
|
|
|
|
|
|
use warnings; |
26
|
|
|
|
|
|
|
use strict; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# this installs the base class and helper functions |
29
|
|
|
|
|
|
|
use Declare::Constraints::Simple-Library; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# we can also automagically provide other libraries |
32
|
|
|
|
|
|
|
# to the importer |
33
|
|
|
|
|
|
|
use base 'Declare::Constraints::Simple::Library::Numericals'; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# with this we define a constraint to check a value |
36
|
|
|
|
|
|
|
# against a serial number regular expression |
37
|
|
|
|
|
|
|
constraint 'SomeSerial', |
38
|
|
|
|
|
|
|
sub { |
39
|
|
|
|
|
|
|
return sub { |
40
|
|
|
|
|
|
|
return _true if $_[0] =~ /\d{3}-\d{3}-\d{4}/; |
41
|
|
|
|
|
|
|
return _false('Not in SomeSerial format'); |
42
|
|
|
|
|
|
|
}; |
43
|
|
|
|
|
|
|
}; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
1; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 DESCRIPTION |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
This base class contains the common library functionalities. This |
50
|
|
|
|
|
|
|
includes helper functions and install mechanisms. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=head1 METHODS |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=head2 install_into($target) |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
Installs the base classes and helper functions into the C<$target> |
57
|
|
|
|
|
|
|
namespace. The C<%CONSTRAINT_GENERATORS> package variable of that class |
58
|
|
|
|
|
|
|
will be used as storage for it's constraints. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=cut |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub install_into { |
63
|
98
|
|
|
98
|
1
|
183
|
my ($class, $target) = @_; |
64
|
|
|
|
|
|
|
|
65
|
13
|
|
|
13
|
|
267
|
{ no strict 'refs'; |
|
13
|
|
|
|
|
716
|
|
|
13
|
|
|
|
|
3532
|
|
|
98
|
|
|
|
|
118
|
|
66
|
98
|
|
|
|
|
123
|
unshift @{$target . '::ISA'}, $class; |
|
98
|
|
|
|
|
1458
|
|
67
|
|
|
|
|
|
|
|
68
|
1176
|
|
|
|
|
11323
|
*{$target . '::' . $_} = $class->can($_) |
69
|
98
|
|
|
|
|
1062
|
for qw/ |
70
|
|
|
|
|
|
|
constraint |
71
|
|
|
|
|
|
|
_apply_checks |
72
|
|
|
|
|
|
|
_listify |
73
|
|
|
|
|
|
|
_result |
74
|
|
|
|
|
|
|
_false |
75
|
|
|
|
|
|
|
_true |
76
|
|
|
|
|
|
|
_info |
77
|
|
|
|
|
|
|
_with_message |
78
|
|
|
|
|
|
|
_with_scope |
79
|
|
|
|
|
|
|
_set_result |
80
|
|
|
|
|
|
|
_get_result |
81
|
|
|
|
|
|
|
_has_result |
82
|
|
|
|
|
|
|
/; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
98
|
|
|
|
|
326
|
1; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=head2 fetch_constraint_declarations() |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
Class method. Returns all constraints registered to the class. |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=cut |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub fetch_constraint_declarations { |
95
|
153
|
|
|
153
|
1
|
212
|
my ($class) = @_; |
96
|
|
|
|
|
|
|
|
97
|
13
|
|
|
13
|
|
67
|
{ no strict 'refs'; |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
469
|
|
|
153
|
|
|
|
|
178
|
|
98
|
13
|
|
|
13
|
|
138
|
no warnings; |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
1321
|
|
99
|
153
|
|
|
|
|
161
|
return keys %{$class . '::CONSTRAINT_GENERATORS'}; |
|
153
|
|
|
|
|
1244
|
|
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
=head2 fetch_constraint_generator($name) |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
Class method. Returns the constraint generator code reference registered |
106
|
|
|
|
|
|
|
under C<$name>. The call will raise a C if the generator could not |
107
|
|
|
|
|
|
|
be found. |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
=cut |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub fetch_constraint_generator { |
112
|
220
|
|
|
220
|
1
|
347
|
my ($class, $name) = @_; |
113
|
|
|
|
|
|
|
|
114
|
220
|
|
|
|
|
227
|
my $generator = do { |
115
|
13
|
|
|
13
|
|
86
|
no strict 'refs'; |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
4693
|
|
116
|
220
|
|
|
|
|
208
|
${$class . '::CONSTRAINT_GENERATORS'}{$name}; |
|
220
|
|
|
|
|
819
|
|
117
|
|
|
|
|
|
|
}; |
118
|
220
|
50
|
|
|
|
473
|
croak "Unknown Constraint Generators: $name" |
119
|
|
|
|
|
|
|
unless $generator; |
120
|
|
|
|
|
|
|
|
121
|
220
|
|
|
|
|
930
|
return $class->prepare_generator($name, $generator); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=head2 prepare_generator($constraint_name, $generator) |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Class method. This wraps the C<$generator> in a closure that provides |
127
|
|
|
|
|
|
|
stack and failure-collapsing decisions. |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=cut |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub prepare_generator { |
132
|
220
|
|
|
220
|
1
|
342
|
my ($class, $constraint, $generator) = @_; |
133
|
|
|
|
|
|
|
return sub { |
134
|
356
|
|
|
356
|
|
2541
|
my (@g_args) = @_; |
135
|
356
|
|
|
|
|
1248
|
my $closure = $generator->(@g_args); |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
return sub { |
138
|
571
|
|
|
571
|
|
138710
|
my (@c_args) = @_; |
139
|
|
|
|
|
|
|
|
140
|
571
|
|
|
|
|
753
|
local $FAIL_INFO; |
141
|
571
|
|
|
|
|
2297
|
my $result = $closure->(@c_args); |
142
|
571
|
|
|
|
|
839
|
my $info = ''; |
143
|
571
|
100
|
|
|
|
1105
|
if ($FAIL_INFO) { |
144
|
85
|
|
|
|
|
226
|
$info = $FAIL_INFO; |
145
|
85
|
|
|
|
|
180
|
$info =~ s/([\[\]])/\\$1/gsm; |
146
|
85
|
|
|
|
|
170
|
$info = "[$info]"; |
147
|
|
|
|
|
|
|
} |
148
|
571
|
100
|
|
|
|
1674
|
$result->add_to_stack($constraint . $info) unless $result; |
149
|
|
|
|
|
|
|
|
150
|
571
|
|
|
|
|
1810
|
return $result; |
151
|
354
|
|
|
|
|
3840
|
}; |
152
|
220
|
|
|
|
|
2109
|
}; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=head2 add_constraint_generator($name, $code) |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
Class method. The actual registration method, used by C. |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=cut |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub add_constraint_generator { |
162
|
424
|
|
|
424
|
1
|
835
|
my ($class, $name, $code) = @_; |
163
|
|
|
|
|
|
|
|
164
|
13
|
|
|
13
|
|
104
|
{ no strict 'refs'; |
|
13
|
|
|
|
|
73
|
|
|
13
|
|
|
|
|
51409
|
|
|
424
|
|
|
|
|
439
|
|
165
|
424
|
|
|
|
|
596
|
${$class . '::CONSTRAINT_GENERATORS'}{$name} = $code; |
|
424
|
|
|
|
|
2413
|
|
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
424
|
|
|
|
|
685
|
1; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=head1 HELPER FUNCTIONS |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
Note that some of the helper functions are prefixed with C<_>. Although |
174
|
|
|
|
|
|
|
this means they are internal functions, it is ok to call them, as they |
175
|
|
|
|
|
|
|
have a fixed API. They are not distribution internal, but library |
176
|
|
|
|
|
|
|
internal, and only intended to be used from inside constraints. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=head2 constraint($name, $code) |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
constraint 'Foo', sub { ... }; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
This registers a new constraint in the calling library. Note that |
183
|
|
|
|
|
|
|
constraints B return result objects. To do this, you can use the |
184
|
|
|
|
|
|
|
helper functions L<_result($bool, $msg>, L<_true()> and L<_false($msg)>. |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=cut |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub constraint { |
189
|
424
|
|
|
424
|
1
|
1859
|
my ($name, $code) = @_; |
190
|
424
|
|
|
|
|
721
|
my $target = scalar(caller); |
191
|
424
|
|
|
|
|
1887
|
$target->add_constraint_generator($name => $code); |
192
|
|
|
|
|
|
|
|
193
|
424
|
|
|
|
|
1098
|
1; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=head2 _result($bool, $msg) |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
Returns a new result object. It's validity flag will depend on the |
199
|
|
|
|
|
|
|
C<$bool> argument. The C<$msg> argument is the error message to use on |
200
|
|
|
|
|
|
|
failure. |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
=cut |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub _result { |
205
|
601
|
|
|
601
|
|
1157
|
my ($result, $msg) = @_; |
206
|
601
|
|
|
|
|
2010
|
my $result_obj = Result->new; |
207
|
601
|
|
|
|
|
1997
|
$result_obj->set_valid($result); |
208
|
601
|
100
|
66
|
|
|
1604
|
$result_obj->set_message( |
209
|
|
|
|
|
|
|
$FAIL_MESSAGE || $msg || $FAIL_MESSAGE_DEFAULT) |
210
|
|
|
|
|
|
|
unless $result_obj->is_valid; |
211
|
601
|
|
|
|
|
1588
|
return $result_obj; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=head2 _false($msg) |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
Returns a non-valid result object, with it's message set to C<$msg>. |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=head2 _true() |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
Returns a valid result object. |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=cut |
223
|
|
|
|
|
|
|
|
224
|
95
|
|
|
95
|
|
320
|
sub _false { _result(0, @_) } |
225
|
327
|
|
|
327
|
|
888
|
sub _true { _result(1, @_) } |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=head2 _info($info) |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
Sets the current failure info to use in the stack info part. |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=cut |
232
|
|
|
|
|
|
|
|
233
|
34
|
|
|
34
|
|
100
|
sub _info { $FAIL_INFO = shift } |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
=head2 _apply_checks($value, \@constraints, [$info]) |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
This applies all constraints in the C<\@constraints> array reference to |
238
|
|
|
|
|
|
|
the passed C<$value>. You can optionally specify an C<$info> string to be |
239
|
|
|
|
|
|
|
used in the stack of the newly created non-valid results. |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=cut |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub _apply_checks { |
244
|
163
|
|
|
163
|
|
276
|
my ($value, $checks, $info) = @_; |
245
|
163
|
|
50
|
|
|
313
|
$checks ||= []; |
246
|
163
|
100
|
|
|
|
344
|
$FAIL_INFO = $info if $info; |
247
|
163
|
|
|
|
|
263
|
for (@$checks) { |
248
|
163
|
|
|
|
|
417
|
my $result = $_->($value); |
249
|
163
|
100
|
|
|
|
483
|
return $result unless $result->is_valid; |
250
|
|
|
|
|
|
|
} |
251
|
133
|
|
|
|
|
255
|
return _true; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=head2 _listify($value) |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
Puts C<$value> into an array reference and returns it, if it isn't |
257
|
|
|
|
|
|
|
already one. |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=cut |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub _listify { |
262
|
98
|
|
|
98
|
|
148
|
my ($value) = @_; |
263
|
98
|
100
|
|
|
|
544
|
return (ref($value) eq 'ARRAY' ? $value : [$value]); |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
=head2 _with_message($msg, $closure, @args) |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
This is the internal version of the general C constraint. It |
269
|
|
|
|
|
|
|
sets the current overriden message to C<$msg> and executes the |
270
|
|
|
|
|
|
|
C<$closure> with C<@args> as arguments. |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
=cut |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
sub _with_message { |
275
|
14
|
|
|
14
|
|
33
|
my ($msg, $closure, @args) = @_; |
276
|
14
|
|
|
|
|
37
|
local $FAIL_MESSAGE = $msg; |
277
|
14
|
|
|
|
|
40
|
return $closure->(@args); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
=head2 _with_scope($scope_name, $constraint, @args) |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
Applies the C<$constraint> to C<@args> in a newly created scope named |
283
|
|
|
|
|
|
|
by C<$scope_name>. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=cut |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub _with_scope { |
288
|
8
|
|
|
8
|
|
16
|
my ($scope_name, $closure, @args) = @_; |
289
|
8
|
50
|
|
|
|
44
|
local %SCOPES = ($scope_name => {}) |
290
|
|
|
|
|
|
|
unless exists $SCOPES{$scope_name}; |
291
|
8
|
|
|
|
|
24
|
return $closure->(@args); |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=head2 _set_result($scope, $name, $result) |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Stores the given C<$result> unter the name C<$name> in C<$scope>. |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=cut |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
sub _set_result { |
301
|
11
|
|
|
11
|
|
19
|
my ($scope, $name, $result) = @_; |
302
|
11
|
|
|
|
|
61
|
$SCOPES{$scope}{result}{$name} = $result; |
303
|
11
|
|
|
|
|
25
|
1; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=head2 _get_result($scope, $name) |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
Returns the result named C<$name> from C<$scope>. |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=cut |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub _get_result { |
313
|
8
|
|
|
8
|
|
11
|
my ($scope, $name) = @_; |
314
|
8
|
|
|
|
|
31
|
return $SCOPES{$scope}{result}{$name}; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=head2 _has_result($scope, $name) |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
Returns true only if such a result was registered already. |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=cut |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
sub _has_result { |
324
|
9
|
|
|
9
|
|
15
|
my ($scope, $name) = @_; |
325
|
9
|
|
|
|
|
50
|
return exists $SCOPES{$scope}{result}{$name}; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=head1 SEE ALSO |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
L, L |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
=head1 AUTHOR |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
This module is free software, you can redistribute it and/or modify it |
339
|
|
|
|
|
|
|
under the same terms as perl itself. |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=cut |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
1; |