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 109     109   837 use strict;
  109         234  
  109         2919  
6 109     109   524 use warnings;
  109         213  
  109         2915  
7              
8 109     109   6260 use Validation::Class::Util '!has', '!hold';
  109         232  
  109         754  
9 109     109   54388 use Hash::Merge ();
  109         540425  
  109         145473  
10              
11             our $VERSION = '7.900059'; # VERSION
12              
13              
14              
15             sub new {
16              
17 6584     6584 1 492970 my $class = shift;
18              
19 6584 100       15709 $class = ref $class if ref $class;
20              
21 6584         17846 my $arguments = $class->build_args(@_);
22              
23 6584         14017 my $self = bless {}, $class;
24              
25 6584         18135 $self->add($arguments);
26              
27 6584         32115 return $self;
28              
29             }
30              
31              
32             sub add {
33              
34 23888     23888 1 240294 my $self = shift;
35              
36 23888         48911 my $arguments = $self->build_args(@_);
37              
38 23888         38251 while (my ($key, $value) = each %{$arguments}) {
  65185         157140  
39              
40 41297         82017 $self->{$key} = $value;
41              
42             }
43              
44 23888         58142 return $self;
45              
46             }
47              
48              
49             sub clear {
50              
51 1984     1984 1 3976 my ($self) = @_;
52              
53 1984         3050 $self->delete($_) for keys %{$self};
  1984         5583  
54              
55 1984         5967 return $self;
56              
57             }
58              
59              
60             sub count {
61              
62 1973     1973 1 3991 my ($self) = @_;
63              
64 1973         4045 return scalar($self->keys);
65              
66             }
67              
68              
69             sub delete {
70              
71 2191     2191 1 3816 my ($self, $name) = @_;
72              
73 2191         8923 return delete $self->{$name};
74              
75             }
76              
77              
78             sub defined {
79              
80 136330     136330 1 208934 my ($self, $index) = @_;
81              
82 136330         453245 return defined $self->{$index};
83              
84             }
85              
86              
87             sub each {
88              
89 32     32 1 200 my ($self, $code) = @_;
90              
91 32   50 0   100 $code ||= sub {};
92              
93 32         67 while (my @args = each(%{$self})) {
  79         277  
94              
95 47         129 $code->(@args);
96              
97             }
98              
99 32         74 return $self;
100              
101             }
102              
103              
104             sub exists {
105              
106 59220     59220 1 98211 my ($self, $name) = @_;
107              
108 59220 100       205533 return exists $self->{$name} ? 1 : 0;
109              
110             }
111              
112              
113             sub get {
114              
115 165789     165789 1 276756 my ($self, $name) = @_;
116              
117 165789         379216 return $self->{$name};
118              
119             }
120              
121              
122             sub grep {
123              
124 1541     1541 1 3511 my ($self, $pattern) = @_;
125              
126 1541 50       5349 $pattern = qr/$pattern/ unless "REGEXP" eq uc ref $pattern;
127              
128 1541         4236 return $self->new(map {$_=>$self->get($_)}grep{$_=~$pattern}($self->keys));
  0         0  
  5119         21113  
129              
130             }
131              
132              
133             sub has {
134              
135 136330     136330 1 223396 my ($self, $name) = @_;
136              
137 136330 100 100     224100 return ($self->defined($name) || $self->exists($name)) ? 1 : 0;
138              
139             }
140              
141              
142             sub hash {
143              
144 21610     21610 1 36578 my ($self) = @_;
145              
146 21610         41773 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 13797     13797 1 23568 my ($self) = @_;
176              
177 13797         19071 return (keys(%{$self->hash}));
  13797         25302  
178              
179             }
180              
181              
182             sub list {
183              
184 21610     21610 1 35283 my ($self) = @_;
185              
186 21610         30241 return (%{$self});
  21610         183207  
187              
188             }
189              
190              
191             sub merge {
192              
193 1792     1792 1 3079 my $self = shift;
194              
195 1792         4552 my $arguments = $self->build_args(@_);
196              
197 1792         6118 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 1792         116526 eval { $self->add($merger->merge($arguments, $self->hash)) };
  1792         4368  
203              
204 1792         53693 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 1200 my ($self, $function, @arguments) = @_;
223              
224 598   50     2410 $function ||= 'keys';
225              
226 598         1466 my @keys = ($self->$function(@arguments));
227              
228 598         1635 my @pairs = map {{ key => $_, value => $self->get($_) }} (@keys);
  3141         5626  
229              
230 598         2195 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 8 my ($self, $code) = @_;
278              
279             return "CODE" eq ref $code ?
280 2 50       13 sort { $a->$code($b) } ($self->keys) : sort { $a cmp $b } ($self->keys);
  0         0  
  10         23  
281              
282             }
283              
284              
285             sub values {
286              
287 2646     2646 1 5489 my ($self) = @_;
288              
289 2646         4379 return (values(%{$self->hash}));
  2646         6298  
290              
291             }
292              
293             1;
294              
295             __END__