File Coverage

blib/lib/Declare/Constraints/Simple/Library/Base.pm
Criterion Covered Total %
statement 101 101 100.0
branch 14 16 87.5
condition 3 5 60.0
subroutine 29 29 100.0
pod 6 6 100.0
total 153 157 97.4


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;