File Coverage

blib/lib/Validation/Class/Mapping.pm
Criterion Covered Total %
statement 76 104 73.0
branch 8 14 57.1
condition 5 7 71.4
subroutine 22 32 68.7
pod 23 23 100.0
total 134 180 74.4


line stmt bran cond sub pod time code
1             # ABSTRACT: Generic Container Class for a Hash Reference
2              
3             package Validation::Class::Mapping;
4              
5 108     108   1753 use strict;
  108         1321  
  108         8191  
6 108     108   2755 use warnings;
  108         1240  
  108         8799  
7              
8 108     108   10309 use Validation::Class::Util '!has', '!hold';
  108         232  
  108         757  
9 108     108   93943 use Hash::Merge ();
  108         323293  
  108         143439  
10              
11             our $VERSION = '7.900057'; # VERSION
12              
13              
14              
15             sub new {
16              
17 6524     6524 1 619141 my $class = shift;
18              
19 6524 100       15830 $class = ref $class if ref $class;
20              
21 6524         21963 my $arguments = $class->build_args(@_);
22              
23 6524         13817 my $self = bless {}, $class;
24              
25 6524         16255 $self->add($arguments);
26              
27 6524         33653 return $self;
28              
29             }
30              
31              
32             sub add {
33              
34 23610     23610 1 133194 my $self = shift;
35              
36 23610         63594 my $arguments = $self->build_args(@_);
37              
38 23610         34873 while (my ($key, $value) = each %{$arguments}) {
  64410         186164  
39              
40 40800         85564 $self->{$key} = $value;
41              
42             }
43              
44 23610         67573 return $self;
45              
46             }
47              
48              
49             sub clear {
50              
51 1960     1960 1 2913 my ($self) = @_;
52              
53 1960         2409 $self->delete($_) for keys %{$self};
  1960         5761  
54              
55 1960         6612 return $self;
56              
57             }
58              
59              
60             sub count {
61              
62 1962     1962 1 2925 my ($self) = @_;
63              
64 1962         4154 return scalar($self->keys);
65              
66             }
67              
68              
69             sub delete {
70              
71 2191     2191 1 2882 my ($self, $name) = @_;
72              
73 2191         6174 return delete $self->{$name};
74              
75             }
76              
77              
78             sub defined {
79              
80 135216     135216 1 178860 my ($self, $index) = @_;
81              
82 135216         642484 return defined $self->{$index};
83              
84             }
85              
86              
87             sub each {
88              
89 32     32 1 64 my ($self, $code) = @_;
90              
91 32   50 0   111 $code ||= sub {};
92              
93 32         53 while (my @args = each(%{$self})) {
  79         307  
94              
95 47         138 $code->(@args);
96              
97             }
98              
99 32         82 return $self;
100              
101             }
102              
103              
104             sub exists {
105              
106 58605     58605 1 80137 my ($self, $name) = @_;
107              
108 58605 100       317987 return exists $self->{$name} ? 1 : 0;
109              
110             }
111              
112              
113             sub get {
114              
115 164533     164533 1 238443 my ($self, $name) = @_;
116              
117 164533         451648 return $self->{$name};
118              
119             }
120              
121              
122             sub grep {
123              
124 1535     1535 1 2672 my ($self, $pattern) = @_;
125              
126 1535 50       5173 $pattern = qr/$pattern/ unless "REGEXP" eq uc ref $pattern;
127              
128 1535         3782 return $self->new(map {$_=>$self->get($_)}grep{$_=~$pattern}($self->keys));
  0         0  
  5118         20294  
129              
130             }
131              
132              
133             sub has {
134              
135 135216     135216 1 189994 my ($self, $name) = @_;
136              
137 135216 100 100     251598 return ($self->defined($name) || $self->exists($name)) ? 1 : 0;
138              
139             }
140              
141              
142             sub hash {
143              
144 21406     21406 1 29814 my ($self) = @_;
145              
146 21406         44613 return {$self->list};
147              
148             }
149              
150              
151             sub iterator {
152              
153 0     0 1 0 my ($self, $function, @arguments) = @_;
154              
155             $function = 'keys'
156 0 0       0 unless grep { $function eq $_ } ('sort', 'rsort', 'nsort', 'rnsort');
  0         0  
157              
158 0         0 my @keys = ($self->$function(@arguments));
159              
160 0         0 my $i = 0;
161              
162             return sub {
163              
164 0 0   0   0 return unless defined $keys[$i];
165              
166 0         0 return $self->get($keys[$i++]);
167              
168             }
169              
170 0         0 }
171              
172              
173             sub keys {
174              
175 13688     13688 1 18957 my ($self) = @_;
176              
177 13688         15533 return (keys(%{$self->hash}));
  13688         27557  
178              
179             }
180              
181              
182             sub list {
183              
184 21406     21406 1 27422 my ($self) = @_;
185              
186 21406         24193 return (%{$self});
  21406         182780  
187              
188             }
189              
190              
191             sub merge {
192              
193 1761     1761 1 2383 my $self = shift;
194              
195 1761         5052 my $arguments = $self->build_args(@_);
196              
197 1761         6692 my $merger = Hash::Merge->new('LEFT_PRECEDENT');
198              
199             # eval bug in Hash::Merge (v0.12 line 100) will likely never be fixed
200             # https://rt.cpan.org/Public/Bug/Display.html?id=55978
201             # something is hijacking $SIG{__DIE__}
202 1761         17734 eval { $self->add($merger->merge($arguments, $self->hash)) };
  1761         3956  
203              
204 1761         11827 return $self;
205              
206             }
207              
208              
209             sub nsort {
210              
211 0     0 1 0 my ($self) = @_;
212              
213 0     0   0 my $code = sub { $_[0] <=> $_[1] };
  0         0  
214              
215 0         0 return $self->sort($code);
216              
217             }
218              
219              
220             sub pairs {
221              
222 598     598 1 1036 my ($self, $function, @arguments) = @_;
223              
224 598   50     2134 $function ||= 'keys';
225              
226 598         1446 my @keys = ($self->$function(@arguments));
227              
228 598         2120 my @pairs = map {{ key => $_, value => $self->get($_) }} (@keys);
  3119         6223  
229              
230 598         2523 return (@pairs);
231              
232             }
233              
234              
235             sub rmerge {
236              
237 0     0 1 0 my $self = shift;
238              
239 0         0 my $arguments = $self->build_args(@_);
240              
241 0         0 my $merger = Hash::Merge->new('RIGHT_PRECEDENT');
242              
243             # eval bug in Hash::Merge (v0.12 line 100) will likely never be fixed
244             # https://rt.cpan.org/Public/Bug/Display.html?id=55978
245             # something is hijacking $SIG{__DIE__}
246 0         0 eval { $self->add($merger->merge($arguments, $self->hash)) };
  0         0  
247              
248 0         0 return $self;
249              
250             }
251              
252              
253             sub rnsort {
254              
255 0     0 1 0 my ($self) = @_;
256              
257 0     0   0 my $code = sub { $_[1] <=> $_[0] };
  0         0  
258              
259 0         0 return $self->sort($code);
260              
261             }
262              
263              
264             sub rsort {
265              
266 0     0 1 0 my ($self) = @_;
267              
268 0     0   0 my $code = sub { $_[1] cmp $_[0] };
  0         0  
269              
270 0         0 return $self->sort($code);
271              
272             }
273              
274              
275             sub sort {
276              
277 2     2 1 6 my ($self, $code) = @_;
278              
279             return "CODE" eq ref $code ?
280 2 50       11 sort { $a->$code($b) } ($self->keys) : sort { $a cmp $b } ($self->keys);
  0         0  
  10         20  
281              
282             }
283              
284              
285             sub values {
286              
287 2618     2618 1 4238 my ($self) = @_;
288              
289 2618         3270 return (values(%{$self->hash}));
  2618         6617  
290              
291             }
292              
293             1;
294              
295             __END__