File Coverage

blib/lib/Data/Object/Role/Hash.pm
Criterion Covered Total %
statement 146 149 97.9
branch 40 56 71.4
condition 25 37 67.5
subroutine 35 35 100.0
pod 0 29 0.0
total 246 306 80.3


line stmt bran cond sub pod time code
1             # ABSTRACT: Hash Object Role for Perl 5
2             package Data::Object::Role::Hash;
3              
4 44     44   382202 use 5.010;
  44         205  
5 44     44   16685 use Data::Object::Role;
  44         99  
  44         391  
6              
7 44     44   13523 use Data::Object 'codify';
  44         96  
  44         2201  
8 44     44   235 use Scalar::Util 'blessed';
  44         107  
  44         2053  
9 44     44   52087 use Storable 'dclone';
  44         327055  
  44         140834  
10              
11             map with($_), our @ROLES = qw(
12             Data::Object::Role::Defined
13             Data::Object::Role::Collection
14             Data::Object::Role::Detract
15             Data::Object::Role::Keyed
16             Data::Object::Role::Output
17             Data::Object::Role::Ref
18             Data::Object::Role::Values
19             Data::Object::Role::Type
20             );
21              
22             our $VERSION = '0.42'; # VERSION
23              
24             sub aslice {
25 1     1 0 5 goto &array_slice;
26             }
27              
28             sub array_slice {
29 2     2 0 4 my ($hash, @arguments) = @_;
30 2         5 return [@{$hash}{@arguments}];
  2         20  
31             }
32              
33             sub clear {
34 1     1 0 6 goto ∅
35             }
36              
37             sub defined {
38 1     1 0 3 my ($hash, $argument) = @_;
39 1         9 return CORE::defined $hash->{$argument};
40             }
41              
42             sub delete {
43 1     1 0 2 my ($hash, $argument) = @_;
44 1         8 return CORE::delete $hash->{$argument};
45             }
46              
47             sub each {
48 1     1 0 3 my ($hash, $code, @arguments) = @_;
49 1 50       6 $code = codify $code if !ref $code;
50              
51 1         12 for my $key (CORE::keys %$hash) {
52 4         21 $code->($key, $hash->{$key}, @arguments);
53             }
54              
55 1         28 return $hash;
56             }
57              
58             sub each_key {
59 1     1 0 2 my ($hash, $code, @arguments) = @_;
60              
61 1 50       4 $code = codify $code if !ref $code;
62 1         12 $code->($_, @arguments) for CORE::keys %$hash;
63              
64 1         12 return $hash;
65             }
66              
67             sub each_n_values {
68 1     1 0 3 my ($hash, $number, $code, @arguments) = @_;
69              
70 1 50       4 $code = codify $code if !ref $code;
71 1         8 my @values = CORE::values %$hash;
72 1         8 $code->(CORE::splice(@values, 0, $number), @arguments) while @values;
73              
74 1         11 return $hash;
75             }
76              
77             sub each_value {
78 1     1 0 3 my ($hash, $code, @arguments) = @_;
79              
80 1 50       3 $code = codify $code if !ref $code;
81 1         11 $code->($_, @arguments) for CORE::values %$hash;
82              
83 1         13 return $hash;
84             }
85              
86             sub empty {
87 2     2 0 5 my ($hash) = @_;
88 2         18 CORE::delete @$hash{CORE::keys %$hash};
89 2         8 return $hash;
90             }
91              
92             sub exists {
93 1     1 0 2 my ($hash, $key) = @_;
94 1         8 return CORE::exists $hash->{$key};
95             }
96              
97             sub filter_exclude {
98 1     1 0 2 my ($hash, @arguments) = @_;
99 1         3 my %i = map { $_ => $_ } @arguments;
  2         10  
100              
101             return {
102 2 50       10 CORE::map { CORE::exists $hash->{$_} ? ($_ => $hash->{$_}) : () }
103 1         9 CORE::grep { not CORE::exists $i{$_} } CORE::keys %$hash
  4         9  
104             };
105             }
106              
107             sub filter_include {
108 1     1 0 2 my ($hash, @arguments) = @_;
109              
110             return {
111 1 50       2 CORE::map { CORE::exists $hash->{$_} ? ($_ => $hash->{$_}) : () }
  2         14  
112             @arguments
113             };
114             }
115              
116             sub fold {
117 18     18 0 24 my ($data, $path, $store, $cache) = @_;
118              
119 18   100     41 $store ||= {};
120 18   100     35 $cache ||= {};
121              
122 18         29 my $ref = CORE::ref($data);
123 18         38 my $obj = Scalar::Util::blessed($data);
124 18         28 my $adr = Scalar::Util::refaddr($data);
125 18         43 my $tmp = { %$cache };
126              
127 18 50 66     181 if ($adr && $tmp->{$adr}) {
    100 100        
    100 66        
      66        
      66        
128 0         0 $store->{$path} = $data;
129             } elsif ($ref eq 'HASH' || ($obj and $obj->isa('Data::Object::Hash'))) {
130 5         10 $tmp->{$adr} = 1;
131 5 50       12 if (%$data) {
132 5         23 for my $key (CORE::sort(CORE::keys %$data)) {
133 11 100       25 my $place = $path ? CORE::join('.', $path, $key) : $key;
134 11         14 my $value = $data->{$key};
135 11         28 fold($value, $place, $store, $tmp);
136             }
137             } else {
138 0         0 $store->{$path} = {};
139             }
140             } elsif ($ref eq 'ARRAY' || ($obj and $obj->isa('Data::Object::Array'))) {
141 2         5 $tmp->{$adr} = 1;
142 2 50       6 if (@$data) {
143 2         7 for my $idx (0 .. $#$data) {
144 5 50       12 my $place = $path ? CORE::join(':', $path, $idx) : $idx;
145 5         7 my $value = $data->[$idx];
146 5         14 fold($value, $place, $store, $tmp);
147             }
148             } else {
149 0         0 $store->{$path} = [];
150             }
151             } else {
152 11         22 $store->{$path} = $data;
153             }
154              
155 18         51 return $store;
156             }
157              
158             sub get {
159 4     4 0 9 my ($hash, $argument) = @_;
160 4         18 return $hash->{$argument};
161             }
162              
163             sub hash_slice {
164 2     2 0 5 my ($hash, @arguments) = @_;
165 2         5 return {CORE::map { $_ => $hash->{$_} } @arguments};
  4         25  
166             }
167              
168             sub hslice {
169 1     1 0 5 goto &hash_slice;
170             }
171              
172             sub invert {
173 1     1 0 3 my ($hash) = @_;
174              
175 1         1 my $temp = {};
176 1         9 for (CORE::keys %$hash) {
177             CORE::defined $hash->{$_} ?
178             $temp->{CORE::delete $hash->{$_}} = $_ :
179 6 100       20 CORE::delete $hash->{$_};
180             }
181              
182 1         3 for (CORE::keys %$temp) {
183 5         10 $hash->{$_} = CORE::delete $temp->{$_};
184             }
185              
186 1         4 return $hash;
187             }
188              
189             sub iterator {
190 1     1 0 2 my ($hash) = @_;
191 1         4 my @keys = CORE::keys %{$hash};
  1         8  
192              
193 1         3 my $i = 0;
194             return sub {
195 5 100   5   81 return undef if $i > $#keys;
196 4         10 return $hash->{$keys[$i++]};
197             }
198 1         5 }
199              
200             sub keys {
201 2     2 0 3 my ($hash) = @_;
202 2         14 return [CORE::keys %$hash];
203             }
204              
205             sub lookup {
206 16     16 0 23 my ($hash, $path) = @_;
207              
208 16 50 33     150 return undef unless ($hash and $path) and (
      66        
      33        
209             ('HASH' eq ref($hash)) or blessed($hash) and $hash->isa('HASH')
210             );
211              
212 16 100       87 return $hash->{$path} if $hash->{$path};
213              
214 11         12 my $next;
215             my $rest;
216              
217 11         41 ($next, $rest) = $path =~ /(.*)\.([^\.]+)$/;
218 11 100 66     54 return lookup($hash->{$next}, $rest) if $next and $hash->{$next};
219              
220 8         27 ($next, $rest) = $path =~ /([^\.]+)\.(.*)$/;
221 8 50 66     47 return lookup($hash->{$next}, $rest) if $next and $hash->{$next};
222              
223 1         3 return undef;
224             }
225              
226             sub pairs {
227 1     1 0 6 goto &pairs_array;
228             }
229              
230             sub pairs_array {
231 2     2 0 5 my ($hash) = @_;
232 2         18 return [CORE::map { [ $_, $hash->{$_} ] } CORE::keys %$hash];
  8         26  
233             }
234              
235             sub merge {
236 4     4 0 10 my ($left, @arguments) = @_;
237              
238 4 50       10 return dclone $left if ! @arguments;
239 4 50       11 return dclone merge($left, merge(@arguments)) if @arguments > 1;
240              
241 4         6 my ($right) = @arguments;
242 4         18 my (%merge) = %$left;
243              
244 4         13 for my $key (CORE::keys %$right) {
245 5         6 my $lprop = $$left{$key};
246 5         8 my $rprop = $$right{$key};
247              
248             $merge{$key} = ((ref($rprop) eq 'HASH') and (ref($lprop) eq 'HASH'))
249 5 50 66     27 ? merge($$left{$key}, $$right{$key}) : $$right{$key};
250             }
251              
252 4         267 return dclone \%merge;
253             }
254              
255             sub reset {
256 1     1 0 4 my ($hash) = @_;
257 1         234 @$hash{CORE::keys %$hash} = ();
258 1         4 return $hash;
259             }
260              
261             sub reverse {
262 1     1 0 2 my ($hash) = @_;
263              
264 1         2 my $temp = {};
265 1         6 for (CORE::keys %$hash) {
266 5 100       15 $temp->{$_} = $hash->{$_} if CORE::defined $hash->{$_};
267             }
268              
269 1         10 return {CORE::reverse %$temp};
270             }
271              
272             sub set {
273 1     1 0 3 my ($hash, $key, $argument) = @_;
274 1         10 return $hash->{$key} = $argument;
275             }
276              
277             sub unfold {
278 2     2 0 4 my ($hash) = @_;
279              
280 2         5 my $store = {};
281 2         20 for my $key (CORE::sort(CORE::keys(%$hash))) {
282 11         14 my $node = $store;
283 11         22 my @steps = CORE::split(/\./, $key);
284 11         24 for (my $i=0; $i < @steps; $i++) {
285 18         25 my $last = $i == $#steps;
286 18         21 my $step = $steps[$i];
287 18 100       48 if (my @parts = $step =~ /^(\w*):(0|[1-9]\d*)$/) {
288             $node = $node->{$parts[0]}[$parts[1]] = $last
289             ? $hash->{$key}
290             : exists $node->{$parts[0]}[$parts[1]]
291 5 50       35 ? $node->{$parts[0]}[$parts[1]]
    100          
292             : {};
293             } else {
294             $node = $node->{$step} = $last
295             ? $hash->{$key}
296             : exists $node->{$step}
297 13 100       58 ? $node->{$step}
    100          
298             : {};
299             }
300             }
301             }
302              
303 2         7 return $store;
304             }
305              
306             sub values {
307 3     3 0 7 my ($hash) = @_;
308 3         29 return [CORE::values %$hash];
309             }
310              
311             1;
312              
313             __END__