File Coverage

blib/lib/Validation/Class/Prototype.pm
Criterion Covered Total %
statement 791 939 84.2
branch 305 466 65.4
condition 70 154 45.4
subroutine 92 112 82.1
pod 30 67 44.7
total 1288 1738 74.1


line stmt bran cond sub pod time code
1             # ABSTRACT: Data Validation Engine for Validation::Class Classes
2              
3             package Validation::Class::Prototype;
4              
5 108     108   1199 use 5.10.0;
  108         346  
6 108     108   555 use strict;
  108         192  
  108         2292  
7 108     108   1591 use warnings;
  108         250  
  108         7562  
8              
9 108     108   69470 use Validation::Class::Configuration;
  108         332  
  108         3710  
10 108     108   699 use Validation::Class::Directives;
  108         203  
  108         2120  
11 108     108   563 use Validation::Class::Listing;
  108         198  
  108         2303  
12 108     108   553 use Validation::Class::Mapping;
  108         199  
  108         2192  
13 108     108   61387 use Validation::Class::Params;
  108         288  
  108         2765  
14 108     108   695 use Validation::Class::Fields;
  108         216  
  108         2332  
15 108     108   522 use Validation::Class::Errors;
  108         194  
  108         2135  
16 108     108   666 use Validation::Class::Util;
  108         196  
  108         489  
17              
18             our $VERSION = '7.900057'; # VERSION
19              
20 108     108   593 use List::MoreUtils 'uniq', 'firstval';
  108         214  
  108         1070  
21 108     108   57803 use Hash::Flatten 'flatten', 'unflatten';
  108         237  
  108         6824  
22 108     108   570 use Module::Runtime 'use_module';
  108         203  
  108         956  
23 108     108   5006 use Module::Find 'findallmod';
  108         201  
  108         5084  
24 108     108   538 use Scalar::Util 'weaken';
  108         199  
  108         5190  
25 108     108   530 use Hash::Merge 'merge';
  108         228  
  108         5914  
26 108     108   537 use Carp 'confess';
  108         209  
  108         4404  
27 108     108   10377 use Clone 'clone';
  108         41515  
  108         555074  
28              
29              
30             my $_registry = Validation::Class::Mapping->new; # prototype registry
31              
32              
33             hold 'attributes' => sub { Validation::Class::Mapping->new };
34              
35              
36             hold 'builders' => sub { Validation::Class::Listing->new };
37              
38              
39             hold 'configuration' => sub { Validation::Class::Configuration->new };
40              
41              
42             hold 'directives' => sub { Validation::Class::Mapping->new };
43              
44              
45             hold 'documents' => sub { Validation::Class::Mapping->new };
46              
47              
48             hold 'errors' => sub { Validation::Class::Errors->new };
49              
50              
51             hold 'events' => sub { Validation::Class::Mapping->new };
52              
53              
54             hold 'fields' => sub { Validation::Class::Fields->new };
55              
56              
57             has 'filtering' => 'pre';
58              
59              
60             hold 'filters' => sub { Validation::Class::Mapping->new };
61              
62              
63             has 'ignore_failure' => '1';
64              
65              
66             has 'ignore_intervention' => '0';
67              
68              
69             has 'ignore_unknown' => '0';
70              
71              
72             hold 'messages' => sub { Validation::Class::Mapping->new };
73              
74              
75             hold 'methods' => sub { Validation::Class::Mapping->new };
76              
77              
78             hold 'mixins' => sub { Validation::Class::Mixins->new };
79              
80              
81             hold 'package' => sub { undef };
82              
83              
84             hold 'params' => sub { Validation::Class::Params->new };
85              
86              
87             hold 'profiles' => sub { Validation::Class::Mapping->new };
88              
89              
90             hold 'queued' => sub { Validation::Class::Listing->new };
91              
92              
93             has 'report_failure' => 0;
94              
95              
96             has 'report_unknown' => 0;
97              
98              
99             hold 'settings' => sub { Validation::Class::Mapping->new };
100              
101              
102             has 'validated' => 0;
103              
104             has 'stashed' => sub { Validation::Class::Mapping->new };
105              
106             Hash::Merge::specify_behavior(
107             {
108             'SCALAR' => {
109             'SCALAR' => sub {
110             $_[1]
111             },
112             'ARRAY' => sub {
113             [$_[0], @{$_[1]}]
114             },
115             'HASH' => sub {
116             $_[1]
117             },
118             },
119             'ARRAY' => {
120             'SCALAR' => sub {
121             [@{$_[0]}, $_[1]]
122             },
123             'ARRAY' => sub {
124             [@{$_[0]}, @{$_[1]}]
125             },
126             'HASH' => sub {
127             [@{$_[0]}, $_[1]]
128             },
129             },
130             'HASH' => {
131             'SCALAR' => sub {
132             $_[1]
133             },
134             'ARRAY' => sub {
135             $_[1]
136             },
137             'HASH' => sub {
138             Hash::Merge::_merge_hashes($_[0], $_[1])
139             },
140             },
141             },
142             # based on RIGHT_PRECEDENT, STORAGE_PRECEDENT and RETAINMENT_PRECEDENT
143             # ... this is intended to DWIM in the context of role-settings-merging
144             'ROLE_PRECEDENT'
145             );
146              
147             sub new {
148              
149 159     159 0 457 my $class = shift;
150              
151 159         749 my $arguments = $class->build_args(@_);
152              
153             confess
154             "The $class class must be instantiated with a parameter named package ".
155             "whose value is the name of the associated package" unless defined
156 159 50 33     1723 $arguments->{package} && $arguments->{package} =~ /\w/
157             ;
158              
159 159         422 my $self = bless $arguments, $class;
160              
161 159         1061 $_registry->add($arguments->{package}, $self);
162              
163 159         490 return $self;
164              
165             }
166              
167             sub apply_filter {
168              
169 31     31 0 50 my ($self, $filter, $field) = @_;
170              
171 31         41 my $name = $field;
172              
173 31         80 $field = $self->fields->get($field);
174 31         92 $filter = $self->filters->get($filter);
175              
176 31 50 33     470 return unless $field && $filter;
177              
178 31 100       86 if ($self->params->has($name)) {
179              
180 9 50       29 if (isa_coderef($filter)) {
181              
182 9 50       27 if (my $value = $self->params->get($name)) {
183              
184 9 50       24 if (isa_arrayref($value)) {
185 0         0 foreach my $el (@{$value}) {
  0         0  
186 0         0 $el = $filter->($el);
187             }
188             }
189             else {
190 9         26 $value = $filter->($value);
191             }
192              
193 9         30 $self->params->add($name, $value);
194              
195             }
196              
197             }
198              
199             }
200              
201 31         127 return $self;
202              
203             }
204              
205              
206             sub apply_filters {
207              
208 32     32 1 66 my ($self, $state) = @_;
209              
210 32   50     98 $state ||= 'pre'; # state defaults to (pre) filtering
211              
212             # check for and process input filters and default values
213             my $run_filter = sub {
214              
215 47     47   468 my ($name, $spec) = @_;
216              
217 47 50       158 if ($spec->filtering) {
218              
219 47 50       131 if ($spec->filtering eq $state) {
220              
221             # the filters directive should always be an arrayref
222 47 100       190 $spec->filters([$spec->filters]) unless isa_arrayref($spec->filters);
223              
224             # apply filters
225 47         77 $self->apply_filter($_, $name) for @{$spec->filters};
  47         137  
226              
227             }
228              
229             }
230              
231 32         171 };
232              
233 32         113 $self->fields->each($run_filter);
234              
235 32         203 return $self;
236              
237             }
238              
239             sub apply_mixin {
240              
241 526     526 0 895 my ($self, $field, $mixin) = @_;
242              
243 526 100 66     2329 return unless $field && $mixin;
244              
245 470         1264 $field = $self->fields->get($field);
246              
247 470   33     1125 $mixin ||= $field->mixin;
248              
249 470 50 33     2014 return unless $mixin && $field;
250              
251             # mixin values should be in arrayref form
252              
253 470 100       1185 my $mixins = isa_arrayref($mixin) ? $mixin : [$mixin];
254              
255 470         654 foreach my $name (@{$mixins}) {
  470         895  
256              
257 479         1287 my $mixin = $self->mixins->get($name);
258              
259 479 100       1069 next unless $mixin;
260              
261 454         1272 $self->merge_mixin($field->name, $mixin->name);
262              
263             }
264              
265 470         1050 return $self;
266              
267             }
268              
269             sub apply_mixin_field {
270              
271 144     144 0 348 my ($self, $field_a, $field_b) = @_;
272              
273 144 50 33     673 return unless $field_a && $field_b;
274              
275 144         340 $self->check_field($field_a);
276 144         322 $self->check_field($field_b);
277              
278             # some overwriting restricted
279              
280 144         398 my $fields = $self->fields;
281              
282 144         427 $field_a = $fields->get($field_a);
283 144         415 $field_b = $fields->get($field_b);
284              
285 144 50 33     726 return unless $field_a && $field_b;
286              
287 144 50       453 my $name = $field_b->name if $field_b->has('name');
288 144 100       529 my $label = $field_b->label if $field_b->has('label');
289              
290             # merge
291              
292 144         459 $self->merge_field($field_a->name, $field_b->name);
293              
294             # restore
295              
296 144 50       625 $field_b->name($name) if defined $name;
297 144 100       360 $field_b->label($label) if defined $label;
298              
299 144 50       790 $self->apply_mixin($name, $field_a->mixin) if $field_a->can('mixin');
300              
301 144         293 return $self;
302              
303             }
304              
305             sub apply_validator {
306              
307 0     0 0 0 my ( $self, $field_name, $field ) = @_;
308              
309             # does field have a label, if not use field name (e.g. for errors, etc)
310              
311 0 0       0 my $name = $field->{label} ? $field->{label} : $field_name;
312 0         0 my $value = $field->{value} ;
313              
314             # check if required
315              
316 0 0       0 my $req = $field->{required} ? 1 : 0;
317              
318 0 0       0 if (defined $field->{'toggle'}) {
319              
320 0 0       0 $req = 1 if $field->{'toggle'} eq '+';
321 0 0       0 $req = 0 if $field->{'toggle'} eq '-';
322              
323             }
324              
325 0 0 0     0 if ( $req && ( !defined $value || $value eq '' ) ) {
      0        
326              
327             my $error = defined $field->{error} ?
328 0 0       0 $field->{error} : "$name is required";
329              
330 0         0 $field->errors->add($error);
331              
332 0         0 return $self; # if required and fails, stop processing immediately
333              
334             }
335              
336 0 0 0     0 if ( $req || $value ) {
337              
338             # find and process all the validators
339              
340 0         0 foreach my $key (keys %{$field}) {
  0         0  
341              
342 0         0 my $directive = $self->directives->{$key};
343              
344 0 0       0 if ($directive) {
345              
346 0 0       0 if ($directive->{validator}) {
347              
348 0 0       0 if ("CODE" eq ref $directive->{validator}) {
349              
350             # execute validator directives
351             $directive->{validator}->(
352 0         0 $field->{$key}, $value, $field, $self
353             );
354              
355             }
356              
357             }
358              
359             }
360              
361             }
362              
363             }
364              
365 0         0 return $self;
366              
367             }
368              
369             sub check_field {
370              
371 1290     1290 0 2407 my ($self, $name) = @_;
372              
373 1290         3615 my $directives = $self->directives;
374              
375 1290         3762 my $field = $self->fields->get($name);
376              
377 1290         4209 foreach my $key ($field->keys) {
378              
379 11386         28054 my $directive = $directives->get($key);
380              
381 11386 100       27797 unless (defined $directive) {
382 1         10 $self->pitch_error( sprintf
383             "The %s directive supplied by the %s field is not supported",
384             $key, $name
385             );
386             }
387              
388             }
389              
390 1289         6541 return 1;
391              
392             }
393              
394             sub check_mixin {
395              
396 1905     1905 0 2917 my ($self, $name) = @_;
397              
398 1905         5182 my $directives = $self->directives;
399              
400 1905         5484 my $mixin = $self->mixins->get($name);
401              
402 1905         6019 foreach my $key ($mixin->keys) {
403              
404 8216         20809 my $directive = $directives->get($key);
405              
406 8216 50       21055 unless (defined $directive) {
407 0         0 $self->pitch_error( sprintf
408             "The %s directive supplied by the %s mixin is not supported",
409             $key, $name
410             );
411             }
412              
413             }
414              
415 1905         7184 return 1;
416              
417             }
418              
419              
420             sub class {
421              
422 11     11 1 20 my $self = shift;
423              
424 11         28 my ($name, %args) = @_;
425              
426 11 50       31 return unless $name;
427              
428 11         16 my @strings;
429              
430 11         38 @strings = split /\//, $name;
431 11         24 @strings = map { s/[^a-zA-Z0-9]+([a-zA-Z0-9])/\U$1/g; $_ } @strings;
  11         34  
  11         33  
432 11 50       22 @strings = map { /\w/ ? ucfirst $_ : () } @strings;
  11         69  
433              
434 11         39 my $class = join '::', $self->{package}, @strings;
435              
436 11 50       31 return unless $class;
437              
438 11         35 my @attrs = qw(
439              
440             ignore_failure
441             ignore_intervention
442             ignore_unknown
443             report_failure
444             report_unknown
445              
446             ); # to be copied (stash and params copied later)
447              
448 11         20 my %defaults = ( map { $_ => $self->$_ } @attrs );
  55         185  
449              
450 11         46 $defaults{'stash'} = $self->stashed; # copy stash
451 11         31 $defaults{'params'} = $self->get_params; # copy params
452              
453 11         19 my %settings = %{ merge \%args, \%defaults };
  11         40  
454              
455 11         1595 use_module $class;
456              
457 11         303 for (keys %settings) {
458              
459 77 50       344 delete $settings{$_} unless $class->can($_);
460              
461             }
462              
463 11 50       61 return unless $class->can('new');
464 11 50       35 return unless $self->registry->has($class); # isa validation class
465              
466 11         59 my $child = $class->new(%settings);
467              
468             {
469              
470 11 0       25 my $proto_method =
  11 50       57  
471             $child->can('proto') ? 'proto' :
472             $child->can('prototype') ? 'prototype' : undef
473             ;
474              
475 11 50       31 if ($proto_method) {
476              
477 11         44 my $proto = $child->$proto_method;
478              
479 11 50       38 if (defined $settings{'params'}) {
480              
481 11         32 foreach my $key ($proto->params->keys) {
482              
483 13 100       179 if ($key =~ /^$name\.(.*)/) {
484              
485 2 50       8 if ($proto->fields->has($1)) {
486              
487 2         4 push @{$proto->fields->{$1}->{alias}}, $key;
  2         7  
488              
489             }
490              
491             }
492              
493             }
494              
495             }
496              
497             }
498              
499             }
500              
501 11         107 return $child;
502              
503             }
504              
505              
506             sub clear_queue {
507              
508 19     19 1 39 my $self = shift;
509              
510 19         82 my @names = $self->queued->list;
511              
512 19         89 for (my $i = 0; $i < @names; $i++) {
513              
514 120         358 $names[$i] =~ s/^[\-\+]{1}//;
515 120         325 $_[$i] = $self->params->get($names[$i]);
516              
517             }
518              
519 19         70 $self->queued->clear;
520              
521 19         79 return @_;
522              
523             }
524              
525              
526             sub clone_field {
527              
528 122     122 1 234 my ($self, $field, $new_field, $directives) = @_;
529              
530 122   100     338 $directives ||= {};
531              
532 122 50       395 $directives->{name} = $new_field unless $directives->{name};
533              
534             # build a new field from an existing one during runtime
535              
536 122         340 $self->fields->add(
537             $new_field => Validation::Class::Field->new($directives)
538             );
539              
540 122         676 $self->apply_mixin_field($new_field, $field);
541              
542 122         207 return $self;
543              
544             }
545              
546              
547             sub does {
548              
549 5     5 1 13 my ($self, $role) = @_;
550              
551 5         20 my $roles = $self->settings->get('roles');
552              
553 5 100   8   33 return $roles ? (firstval { $_ eq $role } @{$roles}) ? 1 : 0 : 0;
  8 50       46  
  5         23  
554              
555             }
556              
557              
558             sub error_count {
559              
560 450     450 1 769 my ($self) = @_;
561              
562 450         1955 my $i = $self->errors->count;
563              
564 450         1621 $i += $_->errors->count for $self->fields->values;
565              
566 450         3566 return $i;
567              
568             }
569              
570              
571             sub error_fields {
572              
573 0     0 1 0 my ($self, @fields) = @_;
574              
575 0         0 my $failed = {};
576              
577 0 0       0 @fields = $self->fields->keys unless @fields;
578              
579 0         0 foreach my $name (@fields) {
580              
581 0         0 my $field = $self->fields->{$name};
582              
583 0 0       0 if ($field->{errors}->count) {
584              
585 0         0 $failed->{$name} = [$field->{errors}->list];
586              
587             }
588              
589             }
590              
591 0         0 return $failed;
592              
593             }
594              
595              
596             sub errors_to_string {
597              
598 36     36 1 86 my $self = shift;
599              
600             # combine class and field errors
601              
602 36         205 my $errors = Validation::Class::Errors->new([]);
603              
604 36         168 $errors->add($self->errors->list);
605              
606 36         177 $errors->add($_->errors->list) for ($self->fields->values);
607              
608 36         209 return $errors->to_string(@_);
609              
610             }
611              
612             sub flatten_params {
613              
614 0     0 0 0 my ($self, $hash) = @_;
615              
616 0 0       0 if ($hash) {
617              
618 0         0 $hash = Hash::Flatten::flatten($hash);
619              
620 0         0 $self->params->add($hash);
621              
622             }
623              
624 0   0     0 return $self->params->flatten->hash || {};
625              
626             }
627              
628              
629             sub get_errors {
630              
631 19     19 1 46 my ($self, @criteria) = @_;
632              
633 19         88 my $errors = Validation::Class::Errors->new([]); # combined errors
634              
635 19 50       69 if (!@criteria) {
    0          
636              
637 19         76 $errors->add($self->errors->list);
638              
639 19         74 $errors->add($_->errors->list) for ($self->fields->values);
640              
641             }
642              
643             elsif (isa_regexp($criteria[0])) {
644              
645 0         0 my $query = $criteria[0];
646              
647 0         0 $errors->add($self->errors->grep($query)->list);
648 0         0 $errors->add($_->errors->grep($query)->list) for $self->fields->values;
649              
650             }
651              
652             else {
653              
654             $errors->add($_->errors->list)
655 0         0 for map {$self->fields->get($_)} @criteria;
  0         0  
656              
657             }
658              
659 19         125 return ($errors->list);
660              
661             }
662              
663              
664             sub get_fields {
665              
666 0     0 1 0 my ($self, @fields) = @_;
667              
668 0 0       0 return () unless @fields;
669              
670 0 0       0 return (map { $self->fields->get($_) || undef } @fields);
  0         0  
671              
672             }
673              
674              
675             sub get_hash {
676              
677 0     0 1 0 my ($self) = @_;
678              
679 0         0 return { map { $_ => $self->get_values($_) } $self->fields->keys };
  0         0  
680              
681             }
682              
683              
684             sub get_params {
685              
686 11     11 1 24 my ($self, @params) = @_;
687              
688 11   50     31 my $params = $self->params->hash || {};
689              
690 11 50       36 if (@params) {
691              
692             return @params ?
693 0 0       0 (map { defined $params->{$_} ? $params->{$_} : undef } @params) :
  0 0       0  
694             ()
695             ;
696              
697             }
698              
699             else {
700              
701 11         31 return $params;
702              
703             }
704              
705             }
706              
707              
708             sub get_values {
709              
710 0     0 1 0 my ($self, @fields) = @_;
711              
712 0 0       0 return () unless @fields;
713             return (
714             map {
715 0         0 my $field = $self->fields->get($_);
  0         0  
716 0         0 my $param = $self->params->get($_);
717 0 0 0     0 $field->readonly ?
      0        
718             $field->default || undef :
719             $field->value || $param
720             ;
721             } @fields
722             );
723              
724             }
725              
726              
727             sub is_valid {
728              
729 400     400 1 745 my ($self) = @_;
730              
731 400 100       1359 return $self->error_count ? 0 : 1;
732              
733             }
734              
735             sub merge_field {
736              
737 144     144 0 258 my ($self, $field_a, $field_b) = @_;
738              
739 144 50 33     652 return unless $field_a && $field_b;
740              
741 144         390 my $directives = $self->directives;
742              
743 144         428 $field_a = $self->fields->get($field_a);
744 144         404 $field_b = $self->fields->get($field_b);
745              
746 144 50 33     687 return unless $field_a && $field_b;
747              
748             # keep in mind that in this case we're using field_b as a mixin
749              
750 144         483 foreach my $pair ($field_b->pairs) {
751              
752 1295         1593 my ($key, $value) = @{$pair}{'key', 'value'};
  1295         2824  
753              
754             # skip unless the directive is mixin compatible
755              
756 1295 100       3770 next unless $directives->get($key)->mixin;
757              
758             # do not override existing keys but multi values append
759              
760 850 100       2357 if ($field_a->has($key)) {
761              
762 269 100       743 next unless $directives->get($key)->multi;
763              
764             }
765              
766 628 50       1900 if ($directives->get($key)->field) {
767              
768             # can the directive have multiple values, merge array
769              
770 628 100       1616 if ($directives->get($key)->multi) {
771              
772             # if field has existing array value, merge unique
773              
774 271 100       992 if (isa_arrayref($field_a->{$key})) {
775              
776 21 50       69 my @values = isa_arrayref($value) ? @{$value} : ($value);
  21         57  
777              
778 21         44 push @values, @{$field_a->{$key}};
  21         49  
779              
780 21         99 @values = uniq @values;
781              
782 21         96 $field_a->{$key} = [@values];
783              
784             }
785              
786             # simple copy
787              
788             else {
789              
790 250 100       605 $field_a->{$key} = isa_arrayref($value) ? $value : [$value];
791              
792             }
793              
794             }
795              
796             # simple copy
797              
798             else {
799              
800 357         1037 $field_a->{$key} = $value;
801              
802             }
803              
804             }
805              
806             }
807              
808 144         735 return $self;
809              
810             }
811              
812             sub merge_mixin {
813              
814 454     454 0 741 my ($self, $field, $mixin) = @_;
815              
816 454 50 33     1913 return unless $field && $mixin;
817              
818 454         1169 my $directives = $self->directives;
819              
820 454         1181 $field = $self->fields->get($field);
821 454         1252 $mixin = $self->mixins->get($mixin);
822              
823 454         1675 foreach my $pair ($mixin->pairs) {
824              
825 1824         2298 my ($key, $value) = @{$pair}{'key', 'value'};
  1824         3942  
826              
827             # do not override existing keys but multi values append
828              
829 1824 100       5302 if ($field->has($key)) {
830              
831 1648 100       4257 next unless $directives->get($key)->multi;
832              
833             }
834              
835 532 50       1685 if ($directives->get($key)->field) {
836              
837             # can the directive have multiple values, merge array
838              
839 532 100       1394 if ($directives->get($key)->multi) {
840              
841             # if field has existing array value, merge unique
842              
843 410 100       1191 if (isa_arrayref($field->{$key})) {
844              
845 354 100       826 my @values = isa_arrayref($value) ? @{$value} : ($value);
  330         742  
846              
847 354         529 push @values, @{$field->{$key}};
  354         850  
848              
849 354         1776 @values = uniq @values;
850              
851 354         1646 $field->{$key} = [@values];
852              
853             }
854              
855             # merge copy
856              
857             else {
858              
859 56 100       157 my @values = isa_arrayref($value) ? @{$value} : ($value);
  43         119  
860              
861 56 100       174 push @values, $field->{$key} if $field->{$key};
862              
863 56         343 @values = uniq @values;
864              
865 56         302 $field->{$key} = [@values];
866              
867             }
868              
869             }
870              
871             # simple copy
872              
873             else {
874              
875 122         388 $field->{$key} = $value;
876              
877             }
878              
879             }
880              
881             }
882              
883 454         1882 return $field;
884              
885             }
886              
887              
888             sub normalize {
889              
890 610     610 1 1214 my ($self, $context) = @_;
891              
892             # we need context
893              
894             confess
895              
896             "Context object ($self->{package} class instance) required ".
897 610 50       2066 "to perform validation" unless $self->{package} eq ref $context
898              
899             ;
900              
901             # stash the current context object
902 610         1698 $self->stash->{'normalization.context'} = $context;
903              
904             # resets
905              
906 610         2175 $self->validated(0);
907              
908 610         1870 $self->reset_fields;
909              
910             # validate mixin directives
911              
912 610         2224 foreach my $key ($self->mixins->keys) {
913              
914 1905         4567 $self->check_mixin($key);
915              
916             }
917              
918             # check for and process a mixin directive
919              
920 610         2883 foreach my $key ($self->fields->keys) {
921              
922 1002         2979 my $field = $self->fields->get($key);
923              
924 1002 50       2729 next unless $field;
925              
926             $self->apply_mixin($key, $field->{mixin})
927 1002 100 33     7213 if $field->can('mixin') && $field->{mixin};
928              
929             }
930              
931             # check for and process a mixin_field directive
932              
933 610         2694 foreach my $key ($self->fields->keys) {
934              
935 1002         2926 my $field = $self->fields->get($key);
936              
937 1002 50       2539 next unless $field;
938              
939             $self->apply_mixin_field($key, $field->{mixin_field})
940             if $field->can('mixin_field') && $field->{mixin_field}
941 1002 100 33     6335 ;
942              
943             }
944              
945             # execute normalization events
946              
947 610         2615 foreach my $key ($self->fields->keys) {
948              
949 1002         2659 $self->trigger_event('on_normalize', $key);
950              
951             }
952              
953             # alias checking, ... for duplicate aliases, etc
954              
955 610         1877 my $mapper = {};
956 610         2174 my @fields = $self->fields->keys;
957              
958 610         1996 foreach my $name (@fields) {
959              
960 1002         2995 my $field = $self->fields->get($name);
961 1002 100       3415 my $label = $field->{label} ? $field->{label} : "The field $name";
962              
963 1002 100       3270 if (defined $field->{alias}) {
964              
965             my $aliases = "ARRAY" eq ref $field->{alias}
966 16 50       64 ? $field->{alias} : [$field->{alias}];
967              
968 16         41 foreach my $alias (@{$aliases}) {
  16         38  
969              
970 16 50       54 if ($mapper->{$alias}) {
971              
972             my $alt_field =
973 0         0 $self->fields->get($mapper->{$alias})
974             ;
975              
976             my $alt_label = $alt_field->{label} ?
977 0 0       0 $alt_field->{label} : "the field $mapper->{$alias}"
978             ;
979              
980 0         0 my $error =
981             qq($label contains the alias $alias which is
982             also an alias on $alt_label)
983             ;
984              
985 0         0 $self->throw_error($error);
986              
987             }
988              
989 16 50       55 if ($self->fields->has($alias)) {
990              
991 0         0 my $error =
992             qq($label contains the alias $alias which is
993             the name of an existing field)
994             ;
995              
996 0         0 $self->throw_error($error);
997              
998             }
999              
1000 16         74 $mapper->{$alias} = $name;
1001              
1002             }
1003              
1004             }
1005              
1006             }
1007              
1008             # final checkpoint, validate field directives
1009              
1010 610         1941 foreach my $key ($self->fields->keys) {
1011              
1012 1002         2912 $self->check_field($key);
1013              
1014             }
1015              
1016             # delete the stashed context object
1017 609         2287 delete $self->stash->{'normalization.context'};
1018              
1019 609         1715 return $self;
1020              
1021             }
1022              
1023              
1024             sub param {
1025              
1026 10     10 1 23 my ($self, $name, $value) = @_;
1027              
1028 10 100       29 if (defined $value) {
1029 8         28 $self->params->add($name, $value);
1030 8         29 return $value;
1031             }
1032             else {
1033 2 50       8 return unless $self->params->has($name);
1034 2         9 return $self->params->get($name);
1035             }
1036              
1037             }
1038              
1039             sub pitch_error {
1040              
1041 9     9 0 20 my ($self, $error_message) = @_;
1042              
1043 9         25 $error_message =~ s/\n/ /g;
1044 9         90 $error_message =~ s/\s+/ /g;
1045              
1046 9 100       41 if ($self->ignore_unknown) {
1047              
1048 7 100       30 if ($self->report_unknown) {
1049 2         9 $self->errors->add($error_message);
1050             }
1051              
1052             }
1053              
1054             else {
1055 2         9 $self->throw_error($error_message);
1056             }
1057              
1058 7         23 return $self;
1059              
1060             }
1061              
1062              
1063             sub plugin {
1064              
1065 0     0 1 0 my ($self, $name) = @_;
1066              
1067 0 0       0 return unless $name;
1068              
1069             # transform what looks like a shortname
1070              
1071 0         0 my @strings;
1072              
1073 0         0 @strings = split /\//, $name;
1074 0         0 @strings = map { s/[^a-zA-Z0-9]+([a-zA-Z0-9])/\U$1/g; $_ } @strings;
  0         0  
  0         0  
1075 0 0       0 @strings = map { /\w/ ? ucfirst $_ : () } @strings;
  0         0  
1076              
1077 0         0 my $class = join '::', 'Validation::Class::Plugin', @strings;
1078              
1079 0         0 eval { use_module $class };
  0         0  
1080              
1081 0         0 return $class->new($self);
1082              
1083             }
1084              
1085             sub proxy_methods {
1086              
1087 324     324 0 2955 return qw{
1088              
1089             class
1090             clear_queue
1091             error
1092             error_count
1093             error_fields
1094             errors
1095             errors_to_string
1096             get_errors
1097             get_fields
1098             get_hash
1099             get_params
1100             get_values
1101             fields
1102             filtering
1103             ignore_failure
1104             ignore_intervention
1105             ignore_unknown
1106             is_valid
1107             param
1108             params
1109             plugin
1110             queue
1111             report_failure
1112             report_unknown
1113             reset_errors
1114             reset_fields
1115             reset_params
1116             set_errors
1117             set_fields
1118             set_params
1119             stash
1120              
1121             }
1122              
1123             }
1124              
1125             sub proxy_methods_wrapped {
1126              
1127 159     159 0 865 return qw{
1128              
1129             validate
1130             validates
1131             validate_document
1132             document_validates
1133             validate_method
1134             method_validates
1135             validate_profile
1136             profile_validates
1137              
1138             }
1139              
1140             }
1141              
1142              
1143             sub queue {
1144              
1145 144     144 1 212 my $self = shift;
1146              
1147 144         181 push @{$self->queued}, @_;
  144         766  
1148              
1149 144         256 return $self;
1150              
1151             }
1152              
1153             sub register_attribute {
1154              
1155 14     14 0 32 my ($self, $attribute, $default) = @_;
1156              
1157 14         24 my $settings;
1158              
1159 108     108   846 no strict 'refs';
  108         277  
  108         4107  
1160 108     108   553 no warnings 'redefine';
  108         240  
  108         161038  
1161              
1162 14 50       76 confess "Error creating accessor '$attribute', name has invalid characters"
1163             unless $attribute =~ /^[a-zA-Z_]\w*$/;
1164              
1165 14 50 66     60 confess "Error creating accessor, default must be a coderef or constant"
1166             if ref $default && ref $default ne 'CODE';
1167              
1168 14 50       56 $default = ($settings = $default)->{default} if isa_hashref($default);
1169              
1170 14         24 my $check;
1171             my $code;
1172              
1173 14 50       84 if ($settings) {
1174 0 0       0 if (defined $settings->{isa}) {
1175             $settings->{isa} = 'rw'
1176 0 0 0     0 unless defined $settings->{isa} and $settings->{isa} eq 'ro'
1177             ;
1178             }
1179             }
1180              
1181 14 100       37 if (defined $default) {
1182              
1183             $code = sub {
1184              
1185 31 100   31   1799 if (@_ == 1) {
1186 20 100       119 return $_[0]->{$attribute} if exists $_[0]->{$attribute};
1187 7 100       44 return $_[0]->{$attribute} = ref $default eq 'CODE' ?
1188             $default->($_[0]) : $default;
1189             }
1190 11         39 $_[0]->{$attribute} = $_[1]; $_[0];
  11         148  
1191              
1192 10         41 };
1193              
1194             }
1195              
1196             else {
1197              
1198             $code = sub {
1199              
1200 6 100   6   1086 return $_[0]->{$attribute} if @_ == 1;
1201 2         5 $_[0]->{$attribute} = $_[1]; $_[0];
  2         9  
1202              
1203 4         19 };
1204              
1205             }
1206              
1207 14         53 $self->set_method($attribute, $code);
1208 14         64 $self->configuration->attributes->add($attribute, $code);
1209              
1210 14         52 return $self;
1211              
1212             }
1213              
1214             sub register_builder {
1215              
1216 4     4 0 11 my ($self, $code) = @_;
1217              
1218 4         15 $self->configuration->builders->add($code);
1219              
1220 4         11 return $self;
1221              
1222             }
1223              
1224             sub register_directive {
1225              
1226 3     3 0 6 my ($self, $name, $code) = @_;
1227              
1228 3         22 my $directive = Validation::Class::Directive->new(
1229             name => $name,
1230             validator => $code
1231             );
1232              
1233 3         14 $self->configuration->directives->add($name, $directive);
1234              
1235 3         10 return $self;
1236              
1237             }
1238              
1239             sub register_document {
1240              
1241 12     12 0 24 my ($self, $name, $data) = @_;
1242              
1243 12         50 $self->configuration->documents->add($name, $data);
1244              
1245 12         33 return $self;
1246              
1247             }
1248              
1249             sub register_ensure {
1250              
1251 2     2 0 6 my ($self, $name, $data) = @_;
1252              
1253 2         6 my $package = $self->{package};
1254 2         10 my $code = $package->can($name);
1255              
1256 2 50       7 confess
1257             "Error creating pre/post condition(s) ".
1258             "around method $name on $package: method does not exist"
1259             unless $code
1260             ;
1261              
1262 2         5 $data->{using} = $code;
1263 2         6 $data->{overwrite} = 1;
1264              
1265 2         13 $self->register_method($name, $data);
1266              
1267 2         6 return $self;
1268              
1269             }
1270              
1271             sub register_field {
1272              
1273 148     148 0 297 my ($self, $name, $data) = @_;
1274              
1275 148         529 my $package = $self->package;
1276 148         284 my $merge = 0;
1277              
1278 148 100       508 $merge = 2 if $name =~ s/^\+{2}//;
1279 148 100       434 $merge = 1 if $name =~ s/^\+{1}//;
1280              
1281 148 50       916 confess "Error creating field $name, name is not properly formatted"
1282             unless $name =~ /^(?:[a-zA-Z_](?:[\w\.]*\w|\w*)(?:\:\d+)?)$/;
1283              
1284 148 100       665 if ($merge) {
1285 2 100 66     8 if ($self->configuration->fields->has($name) && $merge == 2) {
1286 1         5 $self->configuration->fields->get($name)->merge($data);
1287 1         4 return $self;
1288             }
1289              
1290 1 50 33     5 if ($self->configuration->fields->has($name) && $merge == 1) {
1291 1         4 $self->configuration->fields->delete($name);
1292 1         4 $self->configuration->fields->add($name, $data);
1293 1         4 return $self;
1294             }
1295             }
1296              
1297 146 50       584 confess "Error creating accessor $name on $package: attribute collision"
1298             if $self->fields->has($name);
1299              
1300 146 50       1507 confess "Error creating accessor $name on $package: method collision"
1301             if $package->can($name);
1302              
1303 146         351 $data->{name} = $name;
1304              
1305 146         621 $self->configuration->fields->add($name, $data);
1306              
1307 146         291 my $method_name = $name;
1308              
1309 146         403 $method_name =~ s/\W/_/g;
1310              
1311             my $method_routine = sub {
1312              
1313 81     81   10525 my $self = shift @_;
1314              
1315 81         357 my $proto = $self->proto;
1316 81         310 my $field = $proto->fields->get($name);
1317              
1318 81 100       278 if (@_ == 1) {
1319 64         231 $proto->params->add($name, $_[0]);
1320 63         305 $field->value($_[0]);
1321             }
1322              
1323 80         259 return $proto->params->get($name);
1324              
1325 146         702 };
1326              
1327 146         511 $self->set_method($method_name, $method_routine);
1328              
1329 146         427 return $self;
1330              
1331             }
1332              
1333             sub register_filter {
1334              
1335 1     1 0 4 my ($self, $name, $code) = @_;
1336              
1337 1         6 $self->configuration->filters->add($name, $code);
1338              
1339 1         3 return $self;
1340              
1341             }
1342              
1343             sub register_message {
1344              
1345 0     0 0 0 my ($self, $name, $template) = @_;
1346              
1347 0         0 $self->messages->add($name, $template);
1348              
1349 0         0 return $self;
1350              
1351             }
1352              
1353             sub register_method {
1354              
1355 18     18 0 40 my ($self, $name, $data) = @_;
1356              
1357 18         67 my $package = $self->package;
1358              
1359 18 100       76 unless ($data->{overwrite}) {
1360              
1361 16 50       74 confess
1362             "Error creating method $name on $package: ".
1363             "collides with attribute $name"
1364             if $self->attributes->has($name)
1365             ;
1366 16 50       294 confess
1367             "Error creating method $name on $package: ".
1368             "collides with method $name"
1369             if $package->can($name)
1370             ;
1371              
1372             }
1373              
1374 18         85 my @output_keys = my @input_keys = qw(
1375             input input_document input_profile input_method
1376             );
1377              
1378 18         185 s/input/output/ for @output_keys;
1379              
1380             confess
1381             "Error creating method $name, requires " .
1382             "at-least one pre or post-condition option, e.g., " .
1383 0         0 join ', or ', map { "'$_'" } sort @input_keys, @output_keys
1384 18 50       40 unless grep { $data->{$_} } @input_keys, @output_keys
  144         275  
1385             ;
1386              
1387 18   100     85 $data->{using} ||= $package->can("_$name");
1388 18   66     79 $data->{using} ||= $package->can("_process_$name");
1389              
1390             confess
1391             "Error creating method $name, requires the " .
1392             "'using' option and a coderef or subroutine which conforms ".
1393             "to the naming conventions suggested in the documentation"
1394             unless "CODE" eq ref $data->{using}
1395 18 50       86 ;
1396              
1397 18         98 $self->configuration->methods->add($name, $data);
1398              
1399             # create method
1400              
1401 108     108   687 no strict 'refs';
  108         230  
  108         168660  
1402              
1403             my $method_routine = sub {
1404              
1405 47     47   6852 my $self = shift;
1406 47         93 my @args = @_;
1407              
1408 47         75 my $i_validator;
1409             my $o_validator;
1410              
1411 47     55   369 my $input_type = firstval { defined $data->{$_} } @input_keys;
  57         169  
1412 47     150   281 my $output_type = firstval { defined $data->{$_} } @output_keys;
  158         287  
1413 47 100       218 my $input = $input_type ? $data->{$input_type} : '';
1414 47 100       133 my $output = $output_type ? $data->{$output_type} : '';
1415 47         99 my $using = $data->{'using'};
1416 47         76 my $return = undef;
1417              
1418 47 100 100     273 if ($input and $input_type eq 'input') {
    100          
1419              
1420 41 100       187 if (isa_arrayref($input)) {
    100          
    50          
1421 33     31   142 $i_validator = sub {$self->validate(@{$input})};
  33         44  
  33         189  
1422             }
1423              
1424             elsif ($self->proto->profiles->get($input)) {
1425 6     6   33 $i_validator = sub {$self->validate_profile($input, @args)};
  6         33  
1426             }
1427              
1428             elsif ($self->proto->methods->get($input)) {
1429 2     2   10 $i_validator = sub {$self->validate_method($input, @args)};
  2         11  
1430             }
1431              
1432             else {
1433 0         0 confess "Method $name has an invalid input specification";
1434             }
1435              
1436             }
1437              
1438             elsif ($input) {
1439              
1440 4         6 my $type = $input_type;
1441 4         16 $type =~ s/input_//;
1442              
1443 4         9 my $type_list = "${type}s";
1444 4         7 my $type_validator = "validate_${type}";
1445              
1446 4 50 33     35 if ($type && $type_list && $self->proto->$type_list->get($input)) {
      33        
1447 4     4   16 $i_validator = sub {$self->$type_validator($input, @args)};
  4         18  
1448             }
1449              
1450             else {
1451 0         0 confess "Method $name has an invalid input specification";
1452             }
1453              
1454             }
1455              
1456 47 100 66     277 if ($output and $output_type eq 'output') {
    50          
1457              
1458 10 100       32 if (isa_arrayref($output)) {
    50          
    0          
1459 7     5   30 $o_validator = sub {$self->validate(@{$output})};
  5         11  
  5         23  
1460             }
1461              
1462             elsif ($self->proto->profiles->get($output)) {
1463 3     2   14 $o_validator = sub {$self->validate_profile($output, @args)};
  2         10  
1464             }
1465              
1466             elsif ($self->proto->methods->get($output)) {
1467 0     0   0 $o_validator = sub {$self->validate_method($output, @args)};
  0         0  
1468             }
1469              
1470             else {
1471 0         0 confess "Method $name has an invalid output specification";
1472             }
1473              
1474             }
1475              
1476             elsif ($output) {
1477              
1478 0         0 my $type = $output_type;
1479 0         0 $type =~ s/output_//;
1480              
1481 0         0 my $type_list = "${type}s";
1482 0         0 my $type_validator = "validate_${type}";
1483              
1484 0 0 0     0 if ($type && $type_list && $self->proto->$type_list->get($output)) {
      0        
1485 0     0   0 $o_validator = sub {$self->$type_validator($output, @args)};
  0         0  
1486             }
1487              
1488             else {
1489 0         0 confess "Method $name has an invalid output specification";
1490             }
1491              
1492             }
1493              
1494 47 50       134 if ($using) {
1495              
1496 47 50       160 if (isa_coderef($using)) {
1497              
1498 47         140 my $error = "Method $name failed to validate";
1499              
1500             # execute input validation
1501 47 100       118 if ($input) {
1502 45 100       97 unless ($i_validator->(@args)) {
1503 11 50       68 confess $error. " input, ". $self->errors_to_string
1504             if !$self->ignore_failure;
1505 11 50       54 unshift @{$self->errors}, $error
  0         0  
1506             if $self->report_failure;
1507 11         126 return $return;
1508             }
1509             }
1510              
1511             # execute routine
1512 36         182 $return = $using->($self, @args);
1513              
1514             # execute output validation
1515 36 100       153 if ($output) {
1516 7 100       21 confess $error. " output, ". $self->errors_to_string
1517             unless $o_validator->(@args);
1518             }
1519              
1520             # return
1521 34         374 return $return;
1522              
1523             }
1524              
1525             else {
1526              
1527 0         0 confess "Error executing $name, invalid coderef specification";
1528              
1529             }
1530              
1531             }
1532              
1533 0         0 return $return;
1534              
1535 18         174 };
1536              
1537 18         68 $self->set_method($name, $method_routine);
1538              
1539 18         59 return $self;
1540              
1541             };
1542              
1543             sub register_mixin {
1544              
1545 19     19 0 45 my ($self, $name, $data) = @_;
1546              
1547 19         79 my $mixins = $self->configuration->mixins;
1548 19         44 my $merge = 0;
1549              
1550 19 50       80 $merge = 2 if $name =~ s/^\+{2}//;
1551 19 50       68 $merge = 1 if $name =~ s/^\+{1}//;
1552              
1553 19         47 $data->{name} = $name;
1554              
1555 19 50 33     120 if ($mixins->has($name) && $merge == 2) {
1556 0         0 $mixins->get($name)->merge($data);
1557 0         0 return $self;
1558             }
1559              
1560 19 50 33     82 if ($mixins->has($name) && $merge == 1) {
1561 0         0 $mixins->delete($name);
1562 0         0 $mixins->add($name, $data);
1563 0         0 return $self;
1564             }
1565              
1566 19         79 $mixins->add($name, $data);
1567              
1568 19         57 return $self;
1569              
1570             }
1571              
1572             sub register_profile {
1573              
1574 11     11 0 45 my ($self, $name, $code) = @_;
1575              
1576 11         44 $self->configuration->profiles->add($name, $code);
1577              
1578 11         32 return $self;
1579              
1580             }
1581              
1582             sub register_settings {
1583              
1584 17     17 0 40 my ($self, $data) = @_;
1585              
1586 17         29 my @keys;
1587              
1588 17         70 my $name = $self->package;
1589              
1590             # grab configuration settings, not instance settings
1591              
1592 17         106 my $settings = $self->configuration->settings;
1593              
1594             # attach classes
1595 17         65 @keys = qw(class classes);
1596 17 100   34   312 if (my $alias = firstval { exists $data->{$_} } @keys) {
  34         118  
1597              
1598 4         9 $alias = $data->{$alias};
1599              
1600 4         7 my @parents;
1601              
1602 4 100 66     39 if ($alias eq 1 && !ref $alias) {
1603              
1604 3         8 push @parents, $name;
1605              
1606             }
1607              
1608             else {
1609              
1610 1 50       6 push @parents, isa_arrayref($alias) ? @{$alias} : $alias;
  1         3  
1611              
1612             }
1613              
1614 4         10 foreach my $parent (@parents) {
1615              
1616 4   50     29 my $relatives = $settings->{relatives}->{$parent} ||= {};
1617              
1618             # load class children and create relationship map (hash)
1619              
1620 4         20 foreach my $child (findallmod $parent) {
1621              
1622 17         7042 my $name = $child;
1623 17         165 $name =~ s/^$parent\:://;
1624              
1625 17         57 $relatives->{$name} = $child;
1626              
1627             }
1628              
1629             }
1630              
1631             }
1632              
1633             # attach requirements
1634 17         111 @keys = qw(requires required requirement requirements);
1635 17 100   64   97 if (my $alias = firstval { exists $data->{$_} } @keys) {
  64         150  
1636              
1637 2         5 $alias = $data->{$alias};
1638              
1639 2         3 my @requirements;
1640              
1641 2 50       7 push @requirements, isa_arrayref($alias) ? @{$alias} : $alias;
  0         0  
1642              
1643 2         6 foreach my $requirement (@requirements) {
1644              
1645 2         10 $settings->{requirements}->{$requirement} = 1;
1646              
1647             }
1648              
1649             }
1650              
1651             # attach roles
1652 17         85 @keys = qw(base role roles bases);
1653 17 100   49   78 if (my $alias = firstval { exists $data->{$_} } @keys) {
  49         117  
1654              
1655 10         28 $alias = $data->{$alias};
1656              
1657 10         21 my @roles;
1658              
1659 10 50       35 if ($alias) {
1660              
1661 10 100       43 push @roles, isa_arrayref($alias) ? @{$alias} : $alias;
  3         13  
1662              
1663             }
1664              
1665 10 50       55 if (@roles) {
1666              
1667 108     108   693 no strict 'refs';
  108         333  
  108         99059  
1668              
1669 10         30 foreach my $role (@roles) {
1670              
1671 12         28 eval { use_module $role };
  12         55  
1672              
1673             # is the role a validation class?
1674              
1675 12 50       4035 unless ($self->registry->has($role)) {
1676 0         0 confess sprintf
1677             "Can't apply the role %s to the " .
1678             "class %s unless the role uses Validation::Class",
1679             $role,
1680             $self->package
1681             ;
1682             }
1683              
1684 12         43 my $role_proto = $self->registry->get($role);;
1685              
1686             # check requirements
1687              
1688             my $requirements =
1689 12         51 $role_proto->configuration->settings->{requirements};
1690             ;
1691              
1692 12 100       46 if (defined $requirements) {
1693              
1694 2         3 my @failures;
1695              
1696 2         4 foreach my $requirement (keys %{$requirements}) {
  2         6  
1697 2 100       7 unless ($self->package->can($requirement)) {
1698 1         9 push @failures, $requirement;
1699             }
1700             }
1701              
1702 2 100       8 if (@failures) {
1703 1         5 confess sprintf
1704             "Can't use the class %s as a role for ".
1705             "use with the class %s while missing method(s): %s",
1706             $role,
1707             $self->package,
1708             join ', ', @failures
1709             ;
1710             }
1711              
1712             }
1713              
1714 11         22 push @{$settings->{roles}}, $role;
  11         40  
1715              
1716             my @routines =
1717 11         25 grep { defined &{"$role\::$_"} } keys %{"$role\::"};
  784         857  
  784         2696  
  11         207  
1718              
1719 11 50       85 if (@routines) {
1720              
1721             # copy methods
1722              
1723 11         27 foreach my $routine (@routines) {
1724              
1725 762 100       1903 eval {
1726              
1727 37         186 $self->set_method($routine, $role->can($routine));
1728              
1729             } unless $self->package->can($routine);
1730              
1731             }
1732              
1733             # merge configurations
1734              
1735 11         43 my $self_profile = $self->configuration->profile;
1736 11         41 my $role_profile = $role_proto->configuration->profile;
1737              
1738             # manually merge profiles with list/map containers
1739              
1740 11         51 foreach my $attr ($self_profile->keys) {
1741              
1742 121         177 my $lst = 'Validation::Class::Listing';
1743 121         173 my $map = 'Validation::Class::Mapping';
1744              
1745 121         192 my $sp_attr = $self_profile->{$attr};
1746 121         181 my $rp_attr = $role_profile->{$attr};
1747              
1748 121 100 66     888 if (ref($rp_attr) and $rp_attr->isa($map)) {
    50 33        
1749 110         328 $sp_attr->merge($rp_attr->hash);
1750             }
1751              
1752             elsif (ref($rp_attr) and $rp_attr->isa($lst)) {
1753 11         55 $sp_attr->add($rp_attr->list);
1754             }
1755              
1756             else {
1757              
1758             # merge via spec-based merging for standard types
1759              
1760 0         0 Hash::Merge::set_behavior('ROLE_PRECEDENT');
1761              
1762 0         0 $sp_attr = merge $sp_attr => $rp_attr;
1763              
1764 0         0 Hash::Merge::set_behavior('LEFT_PRECEDENT');
1765              
1766             }
1767              
1768             }
1769              
1770             }
1771              
1772             }
1773              
1774             }
1775              
1776             }
1777              
1778 16         106 return $self;
1779              
1780             }
1781              
1782             sub registry {
1783              
1784 1525     1525 0 6340 return $_registry;
1785              
1786             }
1787              
1788              
1789             sub reset {
1790              
1791 0     0 1 0 my $self = shift;
1792              
1793 0         0 $self->queued->clear;
1794              
1795 0         0 $self->reset_fields;
1796              
1797 0         0 $self->reset_params;
1798              
1799 0         0 return $self;
1800              
1801             }
1802              
1803              
1804             sub reset_errors {
1805              
1806 628     628 1 1029 my $self = shift;
1807              
1808 628         2054 $self->errors->clear;
1809              
1810 628         2123 foreach my $field ($self->fields->values) {
1811              
1812 1034         3222 $field->errors->clear;
1813              
1814             }
1815              
1816 628         1787 return $self;
1817              
1818             }
1819              
1820              
1821             sub reset_fields {
1822              
1823 628     628 1 998 my $self = shift;
1824              
1825 628         2041 foreach my $field ( $self->fields->values ) {
1826              
1827             # set default, special directives, etc
1828 1034         3349 $field->{name} = $field->name;
1829 1034         2547 $field->{value} = '';
1830              
1831             }
1832              
1833 628         2621 $self->reset_errors();
1834              
1835 628         1030 return $self;
1836              
1837             }
1838              
1839              
1840             sub reset_params {
1841              
1842 0     0 1 0 my $self = shift;
1843              
1844 0         0 my $params = $self->build_args(@_);
1845              
1846 0         0 $self->params->clear;
1847              
1848 0         0 $self->params->add($params);
1849              
1850 0         0 return $self;
1851              
1852             }
1853              
1854              
1855             sub set_errors {
1856              
1857 8     8 1 21 my ($self, @errors) = @_;
1858              
1859 8 50       46 $self->errors->add(@errors) if @errors;
1860              
1861 8         131 return $self->errors->count;
1862              
1863             }
1864              
1865              
1866             sub set_fields {
1867              
1868 0     0 1 0 my $self = shift;
1869              
1870 0         0 my $fields = $self->build_args(@_);
1871              
1872 0         0 $self->fields->add($fields);
1873              
1874 0         0 return $self;
1875              
1876             }
1877              
1878             sub set_method {
1879              
1880 5870     5870 0 9528 my ($self, $name, $code) = @_;
1881              
1882             # proto and prototype methods cannot be overridden
1883              
1884 5870 50 33     28274 confess "Error creating method $name, method already exists"
      33        
1885             if ($name eq 'proto' || $name eq 'prototype')
1886             && $self->package->can($name)
1887             ;
1888              
1889             # place routines on the calling class
1890              
1891 108     108   634 no strict 'refs';
  108         244  
  108         9590  
1892 108     108   609 no warnings 'redefine';
  108         220  
  108         370743  
1893              
1894 5870         6778 return *{join('::', $self->package, $name)} = $code;
  5870         15314  
1895              
1896             }
1897              
1898              
1899             sub set_params {
1900              
1901 0     0 1 0 my $self = shift;
1902              
1903 0         0 $self->params->add(@_);
1904              
1905 0         0 return $self;
1906              
1907             }
1908              
1909              
1910             sub set_values {
1911              
1912 0     0 0 0 my $self = shift;
1913              
1914 0         0 my $values = $self->build_args(@_);
1915              
1916 0         0 while (my($name, $value) = each(%{$values})) {
  0         0  
1917              
1918 0         0 my $param = $self->params->get($name);
1919 0         0 my $field = $self->fields->get($name);
1920              
1921 0 0       0 next if $field->{readonly};
1922              
1923 0   0     0 $value ||= $field->{default};
1924              
1925 0         0 $self->params->add($name => $value);
1926              
1927 0         0 $field->value($value);
1928              
1929             }
1930              
1931 0         0 return $self;
1932              
1933             }
1934              
1935             sub snapshot {
1936              
1937 165     165 0 367 my ($self) = @_;
1938              
1939             # reset the stash
1940              
1941 165         797 $self->stashed->clear;
1942              
1943             # clone configuration settings and merge into the prototype
1944             # ... which makes the prototype kind've a snapshot of the configuration
1945              
1946 165 50       812 if (my $config = $self->configuration->configure_profile) {
1947              
1948 165         836 my @clonable_configuration_settings = qw(
1949             attributes
1950             directives
1951             documents
1952             events
1953             fields
1954             filters
1955             methods
1956             mixins
1957             profiles
1958             settings
1959             );
1960              
1961 165         424 foreach my $name (@clonable_configuration_settings) {
1962              
1963 1650         6334 my $settings = $config->$name->hash;
1964              
1965 1650         8082 $self->$name->clear->merge($settings);
1966              
1967             }
1968              
1969 165         800 $self->builders->add($config->builders->list);
1970              
1971             }
1972              
1973 165         580 return $self;
1974              
1975             }
1976              
1977              
1978             sub stash {
1979              
1980 9539     9539 1 12908 my $self = shift;
1981              
1982 9539 100 100     24536 return $self->stashed->get($_[0]) if @_ == 1 && ! ref $_[0];
1983              
1984 9535 100 100     22893 $self->stashed->add($_[0]->hash) if @_ == 1 && isa_mapping($_[0]);
1985 9535 100 100     22545 $self->stashed->add($_[0]) if @_ == 1 && isa_hashref($_[0]);
1986 9535 100       19838 $self->stashed->add(@_) if @_ > 1;
1987              
1988 9535         25449 return $self->stashed;
1989              
1990             }
1991              
1992             sub throw_error {
1993              
1994 2     2 0 5 my $error_message = pop;
1995              
1996 2         5 $error_message =~ s/\n/ /g;
1997 2         16 $error_message =~ s/\s+/ /g;
1998              
1999 2         396 confess $error_message ;
2000              
2001             }
2002              
2003             sub trigger_event {
2004              
2005 2618     2618 0 4679 my ($self, $event, $field) = @_;
2006              
2007 2618 50       5665 return unless $event;
2008 2618 50       5161 return unless $field;
2009              
2010 2618         3271 my @order;
2011             my $directives;
2012 2618 100       5513 my $process_all = $event eq 'on_normalize' ? 1 : 0;
2013 2618 100       5166 my $event_type = $event eq 'on_normalize' ? 'normalization' : 'validation';
2014              
2015 2618         7448 $event = $self->events->get($event);
2016 2618         20883 $field = $self->fields->get($field);
2017              
2018 2618 50       6379 return unless defined $event;
2019 2618 50       5385 return unless defined $field;
2020              
2021             # order events via dependency resolution
2022              
2023             $directives = Validation::Class::Directives->new(
2024 2618         3509 {map{$_=>$self->directives->get($_)}(sort keys %{$event})}
  40851         104877  
  2618         24348  
2025             );
2026 2618         18606 @order = ($directives->resolve_dependencies($event_type));
2027 2618 50       8645 @order = keys(%{$event}) unless @order;
  0         0  
2028              
2029             # execute events
2030              
2031 2618         4724 foreach my $i (@order) {
2032              
2033             # skip if the field doesn't have the subscribing directive
2034 40851 100       80522 unless ($process_all) {
2035 28827 100       70360 next unless exists $field->{$i};
2036             }
2037              
2038 20918         32571 my $routine = $event->{$i};
2039 20918         57641 my $directive = $directives->get($i);
2040              
2041             # something else might fudge with the params so we wait
2042             # until now to collect its value
2043 20918         58737 my $name = $field->name;
2044 20918 100       57235 my $param = $self->params->has($name) ? $self->params->get($name) : undef;
2045              
2046             # execute the directive routine associated with the event
2047 20918         74748 $routine->($directive, $self, $field, $param);
2048              
2049             }
2050              
2051 2618         15223 return $self;
2052              
2053             }
2054              
2055             sub unflatten_params {
2056              
2057 1     1 0 3 my ($self) = @_;
2058              
2059 1   50     6 return $self->params->unflatten->hash || {};
2060              
2061             }
2062              
2063              
2064 0     0 0 0 sub has_valid { goto &validate } sub validates { goto &validate } sub validate {
  0     0 0 0  
2065              
2066 406     406 1 1294 my ($self, $context, @fields) = @_;
2067              
2068             confess
2069              
2070             "Context object ($self->{package} class instance) required ".
2071 406 50       1609 "to perform validation" unless $self->{package} eq ref $context
2072              
2073             ;
2074              
2075             # normalize/sanitize
2076              
2077 406         1291 $self->normalize($context);
2078              
2079             # create alias map manually if requested
2080             # ... extremely-deprecated but it remains for back-compat and nostalgia !!!
2081              
2082 406         622 my $alias_map;
2083              
2084 406 100       1963 if (isa_hashref($fields[0])) {
2085              
2086 1         2 $alias_map = $fields[0]; @fields = (); # blank
  1         2  
2087              
2088 1         2 while (my($name, $alias) = each(%{$alias_map})) {
  2         9  
2089              
2090 1         5 $self->params->add($alias => $self->params->delete($name));
2091              
2092 1         3 push @fields, $alias;
2093              
2094             }
2095              
2096             }
2097              
2098             # include queued fields
2099              
2100 406 100       1102 if (@{$self->queued}) {
  406         1363  
2101              
2102 36         60 push @fields, @{$self->queued};
  36         111  
2103              
2104             }
2105              
2106             # include fields from field patterns
2107              
2108 406 100       891 @fields = map { isa_regexp($_) ? (grep { $_ } ($self->fields->sort)) : ($_) }
  512         1505  
  8         22  
2109             @fields;
2110              
2111             # process toggled fields
2112              
2113 406         999 foreach my $field (@fields) {
2114              
2115 518         1754 my ($switch) = $field =~ /^([+-])./;
2116              
2117 518 100       1536 if ($switch) {
2118              
2119             # set field toggle directive
2120              
2121 34         104 $field =~ s/^[+-]//;
2122              
2123 34 100       119 if (my $field = $self->fields->get($field)) {
2124              
2125 32 100       168 $field->toggle(1) if $switch eq '+';
2126 32 100       125 $field->toggle(0) if $switch eq '-';
2127              
2128             }
2129              
2130             }
2131              
2132             }
2133              
2134             # determine what to validate and how
2135              
2136 406 100 100     2194 if (@fields && $self->params->count) {
    100 66        
    50 33        
2137             # validate all parameters against only the fields explicitly
2138             # requested to be validated
2139             }
2140              
2141             elsif (!@fields && $self->params->count) {
2142             # validate all parameters against all defined fields because no fields
2143             # were explicitly requested to be validated, e.g. not explicitly
2144             # defining fields to be validated effectively allows the parameters
2145             # submitted to dictate what gets validated (may not be dangerous)
2146 78         262 @fields = ($self->params->keys);
2147             }
2148              
2149             elsif (@fields && !$self->params->count) {
2150             # validate fields specified although no parameters were submitted
2151             # will likely pass validation unless fields exist with a *required*
2152             # directive or other validation logic expecting a value
2153             }
2154              
2155             else {
2156             # validate all defined fields although no parameters were submitted
2157             # will likely pass validation unless fields exist with a *required*
2158             # directive or other validation logic expecting a value
2159 0         0 @fields = ($self->fields->keys);
2160             }
2161              
2162             # establish the bypass validation flag
2163 406         1680 $self->stash->{'validation.bypass_event'} = 0;
2164              
2165             # stash the current context object
2166 406         1132 $self->stash->{'validation.context'} = $context;
2167              
2168             # report fields requested that do not exist and are not aliases
2169 406         1959 for my $f (grep {!$self->fields->has($_)} uniq @fields) {
  562         1791  
2170             next if grep {
2171 9 100       37 if ($_->has('alias')) {
  13 100       67  
2172             my @aliases = isa_arrayref($_->get('alias')) ?
2173 1 50       7 @{$_->get('alias')} : ($_->get('alias'))
  1         4  
2174             ;
2175 1         3 grep { $f eq $_ } @aliases;
  1         9  
2176             }
2177             }
2178             $self->fields->values
2179             ;
2180 8         66 $self->pitch_error("Data validation field $f does not exist");
2181             }
2182              
2183             # stash fields targeted for validation
2184             $self->stash->{'validation.fields'} =
2185 405         1980 [grep {$self->fields->has($_)} uniq @fields]
  561         1823  
2186             ;
2187              
2188             # execute on_before_validation events
2189             $self->trigger_event('on_before_validation', $_)
2190 405         1102 for @{$self->stash->{'validation.fields'}}
  405         990  
2191             ;
2192              
2193             # execute on_validate events
2194 405 100       1216 unless ($self->stash->{'validation.bypass_event'}) {
2195             $self->trigger_event('on_validate', $_)
2196 375         575 for @{$self->stash->{'validation.fields'}}
  375         930  
2197             ;
2198 375         1508 $self->validated(1);
2199 375 100       1345 $self->validated(2) if $self->is_valid;
2200             }
2201              
2202             # execute on_after_validation events
2203             $self->trigger_event('on_after_validation', $_)
2204 405         735 for @{$self->stash->{'validation.fields'}}
  405         1003  
2205             ;
2206              
2207             # re-establish the bypass validation flag
2208 405         1188 $self->stash->{'validation.bypass_event'} = 0;
2209              
2210             # restore params from alias map manually if requested
2211             # ... extremely-deprecated but it remains for back-compat and nostalgia !!!
2212              
2213 405 100       1177 if ( defined $alias_map ) {
2214              
2215 1         2 while (my($name, $alias) = each(%{$alias_map})) {
  2         8  
2216              
2217 1         4 $self->params->add($name => $self->params->delete($alias));
2218              
2219             }
2220              
2221             }
2222              
2223 405 100       1225 return $self->validated == 2 ? 1 : 0;
2224              
2225             }
2226              
2227              
2228 0     0 0 0 sub document_validates { goto &validate_document } sub validate_document {
2229              
2230 16     16 1 38 my ($self, $context, $ref, $data, $options) = @_;
2231              
2232 16         28 my $name;
2233              
2234 16         66 my $documents = clone $self->documents->hash;
2235              
2236 16         62 my $_fmap = {}; # ad-hoc fields
2237              
2238 16 100       64 if ("HASH" eq ref $ref) {
2239              
2240 1         50 $ref = clone $ref;
2241              
2242 1         12 $name = "DOC" . time() . ($self->documents->count + 1);
2243              
2244             # build document on-the-fly from a hashref
2245 1         3 foreach my $rules (values %{$ref}) {
  1         4  
2246              
2247 7 50       19 next unless "HASH" eq ref $rules;
2248              
2249 7         15 my $id = uc "$rules";
2250 7         28 $id =~ s/\W/_/g;
2251 7         19 $id =~ s/_$//;
2252              
2253 7         22 $self->fields->add($id => $rules);
2254 7         12 $rules = $id;
2255 7         20 $_fmap->{$id} = 1;
2256              
2257             }
2258              
2259 1         4 $documents->{$name} = $ref;
2260              
2261             }
2262              
2263             else {
2264              
2265 15         32 $name = $ref;
2266              
2267             }
2268              
2269 16         69 my $fields = { map { $_ => 1 } ($self->fields->keys) };
  34         97  
2270              
2271 16 50       79 confess "Please supply a registered document name to validate against"
2272             unless $name
2273             ;
2274              
2275             confess "The ($name) document is not registered and cannot be validated against"
2276 16 50 33     89 unless $name && exists $documents->{$name}
2277             ;
2278              
2279 16         44 my $document = $documents->{$name};
2280              
2281             confess "The ($name) document does not contain any mappings and cannot ".
2282 16 50       28 "be validated against" unless keys %{$documents}
  16         73  
2283             ;
2284              
2285 16   100     78 $options ||= {};
2286              
2287             # handle sub-document references
2288              
2289 16         28 for my $key (keys %{$document}) {
  16         60  
2290              
2291             $document->{$key} = $documents->{$document->{$key}} if
2292             $document->{$key} && exists $documents->{$document->{$key}} &&
2293 73 100 66     454 ! $self->fields->has($document->{$key})
      66        
2294             ;
2295              
2296             }
2297              
2298 16         77 $document = flatten $document;
2299              
2300 16         10161 my $signature = clone $document;
2301              
2302             # create document signature
2303              
2304 16         40 for my $key (keys %{$signature}) {
  16         64  
2305              
2306 105         249 (my $new = $key) =~ s/\\//g;
2307              
2308 105         160 $new =~ s/\*/???/g;
2309 105         188 $new =~ s/\.@/:0/g;
2310              
2311 105         203 $signature->{$new} = '???';
2312              
2313 105 100       308 delete $signature->{$key} unless $new eq $key;
2314              
2315             }
2316              
2317 16         252 my $overlay = clone $signature;
2318              
2319 16         38 $_ = undef for values %{$overlay};
  16         85  
2320              
2321             # handle regex expansions
2322              
2323 16         28 for my $key (keys %{$document}) {
  16         52  
2324              
2325 105         176 my $value = delete $document->{$key};
2326              
2327 105         147 my $token;
2328             my $regex;
2329              
2330 105         126 $token = '\.\@';
2331 105         135 $regex = ':\d+';
2332 105         300 $key =~ s/$token/$regex/g;
2333              
2334 105         167 $token = '\*';
2335 105         132 $regex = '[^\.]+';
2336 105         212 $key =~ s/$token/$regex/g;
2337              
2338 105         260 $document->{$key} = $value;
2339              
2340             }
2341              
2342 16         52 my $_dmap = {};
2343 16         45 my $_pmap = {};
2344 16         40 my $_xmap = {};
2345              
2346 16         51 my $_zata = flatten $data;
2347 16         12669 my $_data = merge $overlay, $_zata;
2348              
2349             # remove overlaid patterns if matching nodes exist
2350              
2351 16         1368 for my $key (keys %{$_data}) {
  16         78  
2352              
2353 163 100       452 if ($key =~ /\?{3}/) {
2354              
2355 6         26 (my $regex = $key) =~ s/\?{3}/\\w+/g;
2356              
2357             delete $_data->{$key}
2358 6 100       12 if grep { $_ =~ /$regex/ && $_ ne $key } keys %{$_data};
  82 50       384  
  6         23  
2359              
2360             }
2361              
2362             }
2363              
2364             # generate validation rules
2365              
2366 16         45 for my $key (keys %{$_data}) {
  16         62  
2367              
2368 157         216 my $point = $key;
2369 157         627 $point =~ s/\W/_/g;
2370 157         236 my $label = $key;
2371 157         356 $label =~ s/\:/./g;
2372              
2373 157         211 my $match = 0;
2374              
2375 157         192 my $switch;
2376              
2377 157         190 for my $regex (keys %{$document}) {
  157         503  
2378              
2379 1334 50       2991 if (exists $_data->{$key}) {
2380              
2381 1334         2104 my $field = $document->{$regex};
2382              
2383 1334 100       15691 if ($key =~ /^$regex$/) {
2384              
2385 115 100       333 $switch = $1 if $field =~ s/^([+-])//;
2386              
2387 115         295 my $config = {label => $label};
2388              
2389 115 50       455 $config->{mixin} = $self->fields->get($field)->mixin
2390             if $self->fields->get($field)->can('mixin')
2391             ;
2392              
2393 115         366 $self->clone_field($field, $point => $config);
2394              
2395             $self->apply_mixin($point => $config->{mixin})
2396             if $config->{mixin}
2397 115 100       405 ;
2398              
2399 115         234 $_dmap->{$key} = 1;
2400 115         223 $_pmap->{$point} = $key;
2401              
2402 115         719 $match = 1;
2403              
2404             }
2405              
2406             }
2407              
2408             }
2409              
2410 157         452 $_xmap->{$point} = $key;
2411              
2412             # register node as a parameter
2413 157 100       567 $self->params->add($point => $_data->{$key}) unless ! $match;
2414              
2415             # queue node and requirement
2416 157 100       693 $self->queue($switch ? "$switch$point" : "$point") unless ! $match;
    100          
2417              
2418             # prune unnecessary nodes
2419 157 100 100     954 delete $_data->{$key} if $options->{prune} && ! $match;
2420              
2421             }
2422              
2423             # validate
2424              
2425 16         79 $self->validate($context);
2426              
2427 16         98 $self->clear_queue;
2428              
2429 16         83 my @errors = $self->get_errors;
2430              
2431 16         64 for (sort @errors) {
2432              
2433 7         24 my ($message) = $_ =~ /field (\w+) does not exist/;
2434              
2435 7 50       79 next unless $message;
2436              
2437 0         0 $message = $_xmap->{$message};
2438              
2439 0 0       0 next unless $message;
2440              
2441 0         0 $message =~ s/\W/./g;
2442              
2443             # re-format unknown parameter errors
2444 0         0 $_ = "The parameter $message was not expected and could not be validated";
2445              
2446             }
2447              
2448 16         87 $_dmap = unflatten $_dmap;
2449              
2450 16         5873 while (my($point, $key) = each(%{$_pmap})) {
  131         467  
2451              
2452 115         323 $_data->{$key} = $self->params->get($point); # prepare data
2453              
2454 115 100       531 $self->fields->delete($point) unless $fields->{$point}; # reap clones
2455              
2456             }
2457              
2458 16         35 $self->fields->delete($_) for keys %{$_fmap}; # reap ad-hoc fields
  16         64  
2459              
2460 16         72 $self->reset_fields;
2461              
2462 16 100       71 $self->set_errors(@errors) if @errors; # report errors
2463              
2464 16 50       93 $_[3] = unflatten $_data if defined $_[2]; # restore data
2465              
2466 16         5994 return $self->is_valid;
2467              
2468             }
2469              
2470              
2471 0     0 0 0 sub method_validates { goto &validate_method } sub validate_method {
2472              
2473 8     8 1 24 my ($self, $context, $name, @args) = @_;
2474              
2475             confess
2476             "Context object ($self->{package} class instance) required ".
2477 8 50       36 "to perform method validation" unless $self->{package} eq ref $context;
2478              
2479 8 50       31 return 0 unless $name;
2480              
2481 8         28 $self->normalize($context);
2482 8         36 $self->apply_filters('pre');
2483              
2484 8         32 my $method_spec = $self->methods->{$name};
2485 8         19 my $input = $method_spec->{input};
2486              
2487 8 50       23 if ($input) {
2488              
2489 8         19 my $code = $method_spec->{using};
2490 8         15 my $output = $method_spec->{output};
2491              
2492 8         60 weaken $method_spec->{$_} for ('using', 'output');
2493              
2494 8     6   30 $method_spec->{using} = sub { 1 };
  6         15  
2495 8         17 $method_spec->{output} = undef;
2496              
2497 8         31 $context->$name(@args);
2498              
2499 8         24 $method_spec->{using} = $code;
2500 8         32 $method_spec->{output} = $output;
2501              
2502             }
2503              
2504 8 100       25 return $self->is_valid ? 1 : 0;
2505              
2506             }
2507              
2508              
2509 0     0 0 0 sub profile_validates { goto &validate_profile } sub validate_profile {
2510              
2511 23     23 1 66 my ($self, $context, $name, @args) = @_;
2512              
2513             confess
2514             "Context object ($self->{package} class instance) required ".
2515 23 50       105 "to perform profile validation" unless $self->{package} eq ref $context
2516             ;
2517              
2518 23 50       64 return 0 unless $name;
2519              
2520 23         83 $self->normalize($context);
2521 23         89 $self->apply_filters('pre');
2522              
2523 23 50       81 if (isa_coderef($self->profiles->{$name})) {
2524              
2525 23         81 return $self->profiles->{$name}->($context, @args);
2526              
2527             }
2528              
2529 0           return 0;
2530              
2531             }
2532              
2533             1;
2534              
2535             __END__