File Coverage

blib/lib/Brick.pm
Criterion Covered Total %
statement 72 101 71.2
branch 9 28 32.1
condition 7 17 41.1
subroutine 18 22 81.8
pod 12 13 92.3
total 118 181 65.1


line stmt bran cond sub pod time code
1             package Brick;
2 6     6   3998 use strict;
  6         13  
  6         185  
3              
4 6     6   3571 use subs qw();
  6         159  
  6         225  
5 6     6   38 use vars qw($VERSION);
  6         15  
  6         304  
6              
7 6     6   35 use Carp qw( carp croak );
  6         10  
  6         294  
8 6     6   4005 use Data::Dumper;
  6         42443  
  6         372  
9              
10 6     6   2326 use Brick::Profile;
  6         16  
  6         7359  
11              
12             $VERSION = '0.901';
13              
14             =encoding utf8
15              
16             =head1 NAME
17              
18             Brick - Complex business rule data validation
19              
20             =head1 SYNOPSIS
21              
22             use Brick;
23              
24             my $brick = Brick->new( {
25             external_packages => [ qw(Foo::Validator Bar::Validator) ]
26             } );
27              
28             my $profile = Brick::Profile->new( $brick,
29             [ required => sub { .... } => $hash ],
30             [ optional => optional_fields => $hash ],
31              
32             [ inside => in_number => $hash ],
33              
34             [ outside => ex_number => $hash ],
35             );
36              
37             my %input_from_app = (
38             name => 'Joe Snuffy',
39             ...
40             );
41              
42             my $results = $brick->apply( $profile, \%%input_from_app );
43              
44             =head1 DESCRIPTION
45              
46              
47             =head2 Class methods
48              
49             =over 4
50              
51             =item Brick->new
52              
53             Create a new C. Currently this doesn't do anything other than
54             give you an object so you can call methods.
55              
56             Future ideas? Maybe store several buckets or profiles?
57              
58             =cut
59              
60             sub new
61             {
62 3     3 1 2031 my( $class, $args ) = @_;
63              
64 3         9 my $self = bless {}, $class;
65              
66 3         15 $self->init( $args );
67              
68 3         6 $self->_load_external_packages( @{ $args->{external_packages} } );
  3         19  
69              
70 3         16 $self;
71             }
72              
73             sub _load_external_packages
74             {
75 3     3   9 my( $self, @packages ) = @_;
76              
77 3         12 my $bucket_class = $self->bucket_class;
78              
79 3         10 foreach my $package ( @packages )
80             {
81 0         0 eval "package $bucket_class; require $package; $package->import";
82 0 0       0 croak "Could not load $package: $@" if $@;
83             }
84              
85             }
86              
87             =item Brick->error( MESSAGE )
88              
89             Set the error message from the last things that happened.
90              
91             =item Brick->error_str
92              
93             Get the error message from the last things that happened.
94              
95             =cut
96              
97             {
98             my $Error;
99              
100 1     1 1 545 sub error { $_[0]->_set_error( $_[1] ); croak $_[1]; }
  1         239  
101 1     1 1 663 sub error_str { $Error }
102              
103             # do some stuff to figure out caller, etc
104 1     1   1 sub _set_error { $Error = $_[1] }
105             }
106              
107             =back
108              
109             =head2 Instance methods
110              
111             =over 4
112              
113             =item create_bucket( PROFILE_ARRAYREF )
114              
115             =item create_pool # DEPRECATED
116              
117             This method creates a C instance (or an instance in
118             the package returned by C<$brick->bucket_class> ) based on the profile
119             and returns the bucket instance. Along the way it affects the args
120             hashref in each profile element to add the element name as the key
121             C and the actual coderef (not just the method name) as
122             the key C. The closure generators are allowed to use those keys.
123             For instance, C<__make_constraint>, which is usually the top level
124             closure, uses it to name the closure in the bucket.
125              
126             If the profile doesn't pass C test, this method croaks. You
127             might want to safeguard that by calling C first.
128              
129             my $bucket = do {
130             if( my( $lint ) = $brick->lint( $profile ) )
131             {
132             $brick->create_bucket( $profile );
133             }
134             else
135             {
136             Data::Dumper->Dump( [ $lint ], [qw(lint)] );
137             undef;
138             }
139             };
140              
141             From the profile it extracts the method name to create the closure for
142             it based on its arguments. If the method item is already a code
143             reference it uses it add is, but still adds it to the bucket. This could
144             be handy for using closures from other classes, but I haven't
145             investigated the consequences of that.
146              
147             In scalar context this returns a new bucket instance. If the profile might
148             be bad, use an eval to catch the croak:
149              
150             my $bucket = eval{ $brick->create_bucket( \@profile ) };
151              
152             In list context, it returns the C<$bucket> instance and an anonymous array
153             reference with the stringified closures (which are also the keys in the
154             bucket). The elements in the anonymous array correspond to the elements in
155             the profile. This is handy in C which needs to find the bucket
156             entries for each profile elements. You probably won't need the second
157             argument most of the time.
158              
159             my( $bucket, $refs ) = eval { $brick->create_bucket( \@profile ) };
160              
161             =cut
162              
163 1     1 1 1085 sub create_pool { croak "create_pool is now create_bucket!" }
164              
165             sub create_bucket
166             {
167 3     3 1 8 my( $brick, $profile ) = @_;
168              
169 3 50 50     7 unless( 0 == $brick->profile_class->lint( $profile || [] ) ) # zero but true!
170             {
171 0         0 croak "Bad profile for create_bucket! Perhaps you need to check it with lint"
172             };
173              
174 3         12 my $bucket = $brick->bucket_class->new;
175              
176 3         6 my @coderefs = ();
177 3         9 foreach my $entry ( @$profile )
178             {
179 2         6 my( $name, $method, $args ) = @$entry;
180              
181 2         5 $args->{profile_name} = $name;
182              
183 2         4 $args->{code} = do {
184 2 50 33     4 if( eval { $method->isa( ref {} ) } or
  2 50       29  
    0          
185       0     ref $method eq ref sub {} )
186             {
187 0         0 $method;
188             }
189 2         9 elsif( my $code = eval{ $bucket->$method( $args ) } )
190             {
191 2         5 $code;
192             }
193 0         0 elsif( $@ ) { croak $@ }
194             };
195              
196 2         8 push @coderefs, map { "$_" } $bucket->add_to_bucket( $args );
  2         9  
197             }
198              
199 3 50       17 wantarray ? ( $bucket, \@coderefs ) : $bucket;
200             }
201              
202             =item init
203              
204             Initialize the instance, or return it to a pristine state. Normally
205             you don't have to do this because C does it for you, but if you
206             subclass this you might want to override it.
207              
208             =cut
209              
210             sub init
211             {
212 7     7 1 7623 my( $self, $args ) = @_;
213              
214 7         21 my $bucket_class = $self->bucket_class;
215              
216 7         446 eval "require $bucket_class";
217              
218 7         54 $self->{buckets} = [];
219              
220 7 100 100     69 if( defined $args->{external_packages} && ref $args->{external_packages} eq ref [] )
    100 66        
221             { # defined and array ref
222 1         3 $self->{external_packages} = $args->{external_packages};
223             }
224             elsif( defined $args->{external_packages} &&
225             ! ($args->{external_packages} eq ref []) )
226             { # defined but not array ref
227 1         183 carp "'external_packages' value must be an anonymous array";
228 1         121 $self->{external_packages} = [];
229             }
230             else
231             { # not defined
232 5         20 $self->{external_packages} = [];
233             }
234             }
235              
236             =item add_validator_packages( PACKAGES )
237              
238             Load external validator packages into the bucket. Each of these packages
239             should export the functions they want to make available. C
240             Cs each package and calls its C routine.
241              
242             =cut
243              
244             sub add_validator_packages
245             {
246 0     0 1 0 my( $self, @packages ) = @_;
247              
248 0         0 $self->_load_external_packages( @packages );
249             }
250              
251             =item clone;
252              
253             Based on the current instance, create another one just like it but not
254             connected to it (in effect forking the instance). After the C
255             you can change new instance without affecting the old one. This is
256             handy in C, for instance, where I want a deep copy for a
257             moment. At least I think I want a deep copy.
258              
259             That's the idea. Right now this just returns the same instance. When
260             not using a copy breaks, I'll fix that.
261              
262             =cut
263              
264             sub clone
265             {
266 0     0 1 0 my( $brick ) = shift;
267              
268 0         0 $brick;
269             }
270              
271             sub explain
272             {
273 0     0 0 0 croak "Who's calling Brick::explain? That's in Brick::Profile now!";
274             }
275              
276             =item apply( PROFILE OBJECT, INPUT_DATA_HASHREF )
277              
278             Apply the profile to the data in the input hash reference. The profile
279             can either be a profile object or an array ref that apply() will use to
280             create the profile object.
281              
282             This returns a results object blessed into the class name returned by
283             results_class(), which is Brick::Result by default. If you don't like
284             that, you can override it in your own subclass.
285              
286             =cut
287              
288             sub apply
289             {
290 1     1 1 4 my( $brick, $profile, $input ) = @_;
291              
292             croak "Did not get a profile object in Brick::apply()!\n"
293 1 50       3 unless eval { $profile->isa( $brick->profile_class ) };
  1         4  
294              
295 1         5 my $bucket = $profile->get_bucket;
296 1         4 my $coderefs = $profile->get_coderefs;
297 1         3 my $array = $profile->get_array;
298              
299             my @entries = map {
300 1         4 my $e = $bucket->get_from_bucket( $_ );
  0         0  
301 0         0 [ map { $e->$_ } qw(get_coderef get_name) ]
  0         0  
302             } @$coderefs;
303              
304 1         3 my @results = ();
305              
306 1         4 foreach my $index ( 0 .. $#entries )
307             {
308 0         0 my $e = $entries[$index];
309 0         0 my $name = $array->[$index][0];
310              
311 0         0 my $bucket_entry = $bucket->get_from_bucket( "$e->[0]" );
312 0         0 my $sub_name = $bucket_entry->get_name;
313              
314 0         0 my $result = eval{ $e->[0]->( $input ) };
  0         0  
315 0         0 my $eval_error = $@;
316              
317 0 0 0     0 carp "Brick: $sub_name: eval error \$\@ is not a string or hash reference"
318             unless( ! ref $eval_error or ref $eval_error eq ref {} );
319              
320 0 0 0     0 if( defined $eval_error and ref $eval_error eq ref {} )
    0          
321             {
322 0         0 $result = 0;
323             carp "Brick: $sub_name died with reference, but didn't define 'handler' key"
324 0 0       0 unless exists $eval_error->{handler};
325              
326             carp "Brick: $sub_name died with reference, but didn't define 'message' key"
327 0 0       0 unless exists $eval_error->{message};
328             }
329             elsif( defined $eval_error ) # but not a reference
330             {
331 0         0 $eval_error = {
332             handler => 'program_error',
333             message => $eval_error,
334             program_error => 1,
335             errors => [],
336             };
337             }
338              
339 0         0 my $handler = $array->[$index][1];
340              
341 0         0 my $result_item = $brick->result_class->result_item_class->new(
342             label => $name,
343             method => $handler,
344             result => $result,
345             messages => $eval_error,
346             );
347              
348 0         0 push @results, $result_item;
349             }
350              
351 1         4 return bless \@results, $brick->result_class;
352             }
353              
354             =item bucket_class
355              
356             The namespace where the constraint building blocks are defined. By
357             default this is C. If you don't like that, override
358             this in a subclass. Things that need to work with the bucket class
359             name, such as a factory method, will use the return value of this
360             method.
361              
362             This method also loads the right class, so if you override it,
363             remember to load the class too!
364              
365             =cut
366              
367 25     25 1 2653 sub bucket_class { require Brick::Bucket; 'Brick::Bucket' }
  25         121  
368              
369             =item result_class
370              
371             The namespace that C uses for its result object. By default
372             this is C. If you don't like that, override this in a
373             subclass. Things that need to work with the result class name, such as
374             a factory method, will use the return value of this method.
375              
376             This method also loads the right class, so if you override it,
377             remember to load the class too!
378              
379             =cut
380              
381 2     2 1 485 sub result_class { require Brick::Result; 'Brick::Result' }
  2         10  
382              
383             =item profile_class
384              
385             The namespace for the profile object. By default this is
386             C. If you don't like that, override this in a
387             subclass. Things that need to work with the result class name, such as
388             a factory method, will use the return value of this method.
389              
390             This method also loads the right class, so if you override it,
391             remember to load the class too!
392              
393             =cut
394              
395 16     16 1 5366 sub profile_class { require Brick::Profile; 'Brick::Profile' }
  16         92  
396              
397             =back
398              
399             =head1 TO DO
400              
401             TBA
402              
403             =head1 SEE ALSO
404              
405             L, L
406              
407             =head1 SOURCE AVAILABILITY
408              
409             This source is in Github:
410              
411             https://github.com/briandfoy/brick
412              
413             =head1 AUTHOR
414              
415             brian d foy, C<< >>
416              
417             =head1 COPYRIGHT
418              
419             Copyright © 2007-2021, brian d foy . All rights reserved.
420              
421             You may redistribute this under the terms of the Artistic License 2.0.
422              
423             =cut
424              
425             1;