File Coverage

blib/lib/Validation/Class/Util.pm
Criterion Covered Total %
statement 82 92 89.1
branch 33 52 63.4
condition 5 9 55.5
subroutine 23 27 85.1
pod 0 13 0.0
total 143 193 74.0


line stmt bran cond sub pod time code
1             # Utility Functions for Validation Classes
2              
3             package Validation::Class::Util;
4              
5 108     108   543 use strict;
  108         196  
  108         3014  
6 108     108   564 use warnings;
  108         196  
  108         4620  
7              
8             our $VERSION = '7.900057'; # VERSION
9              
10 108     108   87237 use Module::Runtime 'use_module';
  108         192029  
  108         694  
11 108     108   5408 use Scalar::Util 'blessed';
  108         212  
  108         11016  
12 108     108   563 use Carp 'confess';
  108         203  
  108         7049  
13 108     108   550 use Exporter ();
  108         208  
  108         53498  
14              
15             our @ISA = qw(Exporter);
16             our @EXPORT = qw(
17              
18             build_args
19             build_args_collection
20             has
21             hold
22             isa_arrayref
23             isa_classref
24             isa_coderef
25             isa_hashref
26             isa_listing
27             isa_mapping
28             isa_prototype
29             isa_regexp
30             prototype_registry
31              
32             );
33              
34             sub build_args {
35              
36 47151     47151 0 63882 my $self = shift;
37              
38 47151   66     135110 my $class = ref $self || $self;
39              
40 47151 100       115526 if ( scalar @_ == 1 ) {
    50          
41 19488 50 33     91496 confess
42             "The new() method for $class expects single arguments to " .
43             "take the form of a hash reference"
44             unless defined $_[0] && ref $_[0] eq 'HASH'
45             ;
46 19488         23079 return {%{$_[0]}};
  19488         136735  
47             }
48              
49             elsif ( @_ % 2 ) {
50 0         0 confess
51             "The new() method for $class expects a hash reference or a " .
52             "key/value list. You passed an odd number of arguments"
53             ;
54             }
55              
56             else {
57 27663         87331 return {@_};
58             }
59              
60             }
61              
62             sub build_args_collection {
63              
64 0     0 0 0 my $class = shift;
65              
66             # Validation::Class::Mapping should already be loaded
67 0         0 return Validation::Class::Mapping->new($class->build_args(@_));
68              
69             }
70              
71             sub has {
72              
73 29916     29916 0 52620 my ( $attrs, $default ) = @_;
74              
75 29916 50       63756 return unless $attrs;
76              
77 29916 50 66     96428 confess "Error creating accessor, default must be a coderef or constant"
78             if ref $default && ref $default ne 'CODE';
79              
80 29916 50       92350 $attrs = [$attrs] unless ref $attrs eq 'ARRAY';
81              
82 29916         55422 for my $attr (@$attrs) {
83              
84 29916 50       100263 confess "Error creating accessor '$attr', name has invalid characters"
85             unless $attr =~ /^[a-zA-Z_]\w*$/;
86              
87 29916         34118 my $code;
88              
89 29916 50       53956 if ( defined $default ) {
90              
91             $code = sub {
92              
93 254579 100   254579   557714 if ( @_ == 1 ) {
94 252991 100       1133426 return $_[0]->{$attr} if exists $_[0]->{$attr};
95 19861 100       83932 return $_[0]->{$attr}
96             = ref $default eq 'CODE'
97             ? $default->( $_[0] )
98             : $default;
99             }
100 1588         3290 $_[0]->{$attr} = $_[1];
101 1588         3538 $_[0];
102              
103 29916         111108 };
104              
105             }
106              
107             else {
108              
109             $code = sub {
110              
111 0 0   0   0 return $_[0]->{$attr} if @_ == 1;
112 0         0 $_[0]->{$attr} = $_[1];
113 0         0 $_[0];
114              
115 0         0 };
116              
117             }
118              
119 108     108   607 no strict 'refs';
  108         198  
  108         4090  
120 108     108   533 no warnings 'redefine';
  108         221  
  108         33301  
121              
122 29916         54609 my $class = caller(0);
123              
124 29916         35709 *{"$class\::$attr"} = $code;
  29916         164876  
125              
126             }
127              
128 29916         91852 return;
129              
130             }
131              
132             sub hold {
133              
134 1836     1836 0 3195 my ( $attrs, $default ) = @_;
135              
136 1836 50       4294 return unless $attrs;
137              
138 1836 50       4442 confess "Error creating accessor, default is required and must be a coderef"
139             if ref $default ne 'CODE';
140              
141 1836 50       5395 $attrs = [$attrs] unless ref $attrs eq 'ARRAY';
142              
143 1836         3271 for my $attr (@$attrs) {
144              
145 1836 50       6662 confess "Error creating accessor '$attr', name has invalid characters"
146             unless $attr =~ /^[a-zA-Z_]\w*$/;
147              
148 1836         2184 my $code;
149              
150             $code = sub {
151              
152 122886 50   122886   270714 if ( @_ == 1 ) {
153 122886 100       561234 return $_[0]->{$attr} if exists $_[0]->{$attr};
154 2053         7634 return $_[0]->{$attr} = $default->( $_[0] );
155             }
156              
157             # values are read-only cannot be changed
158 0         0 confess "Error attempting to modify the read-only attribute ($attr)";
159              
160 1836         6329 };
161              
162 108     108   654 no strict 'refs';
  108         207  
  108         3420  
163 108     108   565 no warnings 'redefine';
  108         1355  
  108         52608  
164              
165 1836         3282 my $class = caller(0);
166              
167 1836         2325 *{"$class\::$attr"} = $code;
  1836         10376  
168              
169             }
170              
171 1836         5072 return;
172              
173             }
174              
175             sub import {
176              
177 6387     6387   25616 strict->import;
178 6387         56130 warnings->import;
179              
180 6387         810517 __PACKAGE__->export_to_level(1, @_);
181              
182 6387         4323514 return;
183              
184             }
185              
186             sub isa_arrayref {
187              
188 10632 100   10632 0 46109 return "ARRAY" eq ref(shift) ? 1 : 0;
189              
190             }
191              
192             sub isa_classref {
193              
194 65322     65322 0 85836 my ($object) = @_;
195              
196 65322 50       282262 return blessed(shift) ? 1 : 0;
197              
198             }
199              
200             sub isa_coderef {
201              
202 656 100   656 0 3544 return "CODE" eq ref(shift) ? 1 : 0;
203              
204             }
205              
206             sub isa_hashref {
207              
208 974 100   974 0 4798 return "HASH" eq ref(shift) ? 1 : 0;
209              
210             }
211              
212             sub isa_listing {
213              
214 0 0   0 0 0 return "Validation::Class::Listing" eq ref(shift) ? 1 : 0;
215              
216             }
217              
218             sub isa_mapping {
219              
220 12 100   12 0 119 return "Validation::Class::Mapping" eq ref(shift) ? 1 : 0;
221              
222             }
223              
224             sub isa_prototype {
225              
226 0 0   0 0 0 return prototype_registry->has(shift) ? 1 : 0;
227              
228             }
229              
230             sub isa_regexp {
231              
232 537 100   537 0 2982 return "REGEXP" eq uc(ref(shift)) ? 1 : 0;
233              
234             }
235              
236             sub prototype_registry {
237              
238             # Validation::Class::Prototype should be already loaded
239 1490     1490 0 6340 return Validation::Class::Prototype->registry;
240              
241             }
242              
243             1;