File Coverage

lib/List/Objects/WithUtils/Role/Hash.pm
Criterion Covered Total %
statement 74 74 100.0
branch 12 12 100.0
condition n/a
subroutine 29 29 100.0
total 115 115 100.0


line stmt bran cond sub code
1         package List::Objects::WithUtils::Role::Hash;
2 40     40 use strictures 1;
  40        
  40        
3          
4 40     40 use Module::Runtime ();
  40        
  40        
5 40     40 use Scalar::Util ();
  40        
  40        
6          
7         =pod
8        
9         =for Pod::Coverage HASH_TYPE blessed_or_pkg
10        
11         =cut
12          
13         sub HASH_TYPE () { 'List::Objects::WithUtils::Hash' }
14         sub blessed_or_pkg {
15 23     23   my $pkg;
16 23 100       ($pkg = Scalar::Util::blessed $_[0]) ?
17             $pkg : Module::Runtime::use_module(HASH_TYPE)
18         }
19          
20 40     40 use Role::Tiny;
  40        
  40        
21          
22 48     48 sub array_type { 'List::Objects::WithUtils::Array' }
23 4     4 sub inflated_type { 'List::Objects::WithUtils::Hash::Inflated' }
24 2     2 sub inflated_rw_type { 'List::Objects::WithUtils::Hash::Inflated::RW' }
25          
26         =pod
27        
28         =for Pod::Coverage TO_JSON type
29        
30         =cut
31          
32 2     2 sub is_mutable { 1 }
33 2     2 sub is_immutable { ! $_[0]->is_mutable }
34          
35 1     1 sub type { }
36          
37         sub new {
38 32     32   Module::Runtime::require_module( $_[0]->array_type );
39 32         bless +{ @_[1 .. $#_] }, $_[0]
40         }
41          
42 2     2 sub unbless { +{ %{ $_[0] } } }
  2        
43 40     40 { no warnings 'once'; *TO_JSON = *unbless; }
  40        
  40        
44          
45 2     2 sub clear { %{ $_[0] } = (); $_[0] }
  2        
  2        
46          
47         sub copy {
48 2     2   bless +{ %{ $_[0] } }, blessed_or_pkg($_[0])
  2        
49         }
50          
51         sub inflate {
52 3     3   my ($self, %params) = @_;
53 3 100       my $type = $params{rw} ? 'inflated_rw_type' : 'inflated_type';
54 3         my $pkg = blessed_or_pkg($self);
55 3         Module::Runtime::require_module( $pkg->$type );
56 3         $pkg->$type->new( %$self )
57         }
58          
59 3     3 sub defined { CORE::defined $_[0]->{ $_[1] } }
60 4     4 sub exists { CORE::exists $_[0]->{ $_[1] } }
61          
62 5 100   5 sub is_empty { keys %{ $_[0] } ? 0 : 1 }
  5        
63          
64         sub get {
65 20 100   20   if (@_ > 2) {
66 1           return blessed_or_pkg($_[0])->array_type->new(
67 1             @{ $_[0] }{ @_[1 .. $#_] }
68             )
69           }
70 19         $_[0]->{ $_[1] }
71         }
72          
73         sub sliced {
74           blessed_or_pkg($_[0])->new(
75 3     3     map {;
76 7 100           exists $_[0]->{$_} ?
77                 ( $_ => $_[0]->{$_} )
78                 : ()
79             } @_[1 .. $#_]
80           )
81         }
82          
83         sub set {
84 6     6   my $self = shift;
85 6         my @keysidx = grep {; not $_ % 2 } 0 .. $#_ ;
  16        
86 6         my @valsidx = grep {; $_ % 2 } 0 .. $#_ ;
  16        
87          
88 6         @{$self}{ @_[@keysidx] } = @_[@valsidx];
  6        
89          
90 5         $self
91         }
92          
93         sub delete {
94 3         blessed_or_pkg($_[0])->array_type->new(
95 3     3     CORE::delete @{ $_[0] }{ @_[1 .. $#_] }
96           )
97         }
98          
99         sub keys {
100 5         blessed_or_pkg($_[0])->array_type->new(
101 5     5     CORE::keys %{ $_[0] }
102           )
103         }
104          
105         sub values {
106 2         blessed_or_pkg($_[0])->array_type->new(
107 2     2     CORE::values %{ $_[0] }
108           )
109         }
110          
111         sub kv {
112           blessed_or_pkg($_[0])->array_type->new(
113 2     2     map {; [ $_, $_[0]->{ $_ } ] } CORE::keys %{ $_[0] }
  4        
  2        
114           )
115         }
116          
117         sub kv_sort {
118 2 100   2   if (defined $_[1]) {
119             return blessed_or_pkg($_[0])->array_type->new(
120 4             map {; [ $_, $_[0]->{ $_ } ] }
121 1               CORE::sort {; $_[1]->($a, $b) } CORE::keys %{ $_[0] }
  5        
  1        
122             )
123           }
124           blessed_or_pkg($_[0])->array_type->new(
125 1           map {; [ $_, $_[0]->{ $_ } ] } CORE::sort( CORE::keys %{ $_[0] } )
  4        
  1        
126           )
127         }
128          
129 3     3 sub export { %{ $_[0] } }
  3        
130          
131         1;
132          
133          
134         =pod
135        
136         =head1 NAME
137        
138         List::Objects::WithUtils::Role::Hash - Hash manipulation methods
139        
140         =head1 SYNOPSIS
141        
142         ## Via List::Objects::WithUtils::Hash ->
143         use List::Objects::WithUtils 'hash';
144        
145         my $hash = hash(foo => 'bar');
146        
147         $hash->set(
148         foo => 'baz',
149         pie => 'tasty',
150         );
151        
152         my @matches = $hash->keys->grep(sub {
153         $_[0] =~ /foo/
154         })->all;
155        
156         my $pie = $hash->get('pie')
157         if $hash->exists('pie');
158        
159         for my $pair ( $hash->kv->all ) {
160         my ($key, $val) = @$pair;
161         ...
162         }
163        
164         my $obj = $hash->inflate;
165         my $foo = $obj->foo;
166        
167         ## As a Role ->
168         use Role::Tiny::With;
169         with 'List::Objects::WithUtils::Role::Hash';
170        
171         =head1 DESCRIPTION
172        
173         A L<Role::Tiny> role defining methods for creating and manipulating HASH-type
174         objects.
175        
176         In addition to the methods documented below, these objects provide a
177         C<TO_JSON> method exporting a plain HASH-type reference for convenience when
178         feeding L<JSON::Tiny> or similar.
179        
180         =head2 new
181        
182         Constructs a new HASH-type object.
183        
184         =head2 export
185        
186         my %hash = $hash->export;
187        
188         Returns a raw key/value list.
189        
190         =head2 clear
191        
192         Clears the current hash entirely.
193        
194         Returns the hash object (as of version 1.013).
195        
196         =head2 copy
197        
198         Creates a shallow clone of the current object.
199        
200         =head2 unbless
201        
202         Returns a plain C</HASH> reference (shallow clone).
203        
204         =head2 defined
205        
206         if ( $hash->defined($key) ) { ... }
207        
208         Returns boolean true if the key has a defined value.
209        
210         =head2 delete
211        
212         $hash->delete( @keys );
213        
214         Deletes keys from the hash.
215        
216         Returns an L</array_type> object containing the deleted values.
217        
218         =head2 exists
219        
220         if ( $hash->exists($key) ) { ... }
221        
222         Returns boolean true if the key exists.
223        
224         =head2 get
225        
226         my $val = $hash->get($key);
227         my @vals = $hash->get(@keys)->all;
228        
229         Retrieves a key or list of keys from the hash.
230        
231         If we're taking a slice (multiple keys were specified), values are returned
232         as an L</array_type> object. (See L</sliced> if you'd rather generate a new
233         hash.)
234        
235         =head2 inflate
236        
237         my $obj = hash(foo => 'bar', baz => 'quux')->inflate;
238         my $baz = $obj->baz;
239        
240         Inflates a simple object providing accessors for a hash.
241        
242         By default, accessors are read-only; specifying C<rw => 1> allows setting new
243         values:
244        
245         my $obj = hash(foo => 'bar', baz => 'quux')->inflate(rw => 1);
246         $obj->foo('frobulate');
247        
248         Returns an L</inflated_type> (or L</inflated_rw_type>) object.
249        
250         The default objects provide a C<DEFLATE> method returning a
251         plain hash; this makes it easy to turn inflated objects back into a C<hash()>
252         for modification:
253        
254         my $first = hash( foo => 'bar', baz => 'quux' )->inflate;
255         my $second = hash( $first->DEFLATE, frobulate => 1 )->inflate;
256        
257         =head2 is_empty
258        
259         Returns boolean true if the hash has no keys.
260        
261         =head2 is_mutable
262        
263         Returns boolean true if the hash is mutable; immutable subclasses can override
264         to provide a negative value.
265        
266         =head2 is_immutable
267        
268         The opposite of L</is_mutable>.
269        
270         =head2 keys
271        
272         my @keys = $hash->keys->all;
273        
274         Returns the list of keys in the hash as an L</array_type> object.
275        
276         =head2 values
277        
278         my @vals = $hash->values->all;
279        
280         Returns the list of values in the hash as an L</array_type> object.
281        
282         =head2 kv
283        
284         for my $pair ($hash->kv->all) {
285         my ($key, $val) = @$pair;
286         }
287        
288         Returns an L</array_type> object containing the key/value pairs in the HASH,
289         each of which is a two-element ARRAY.
290        
291         =head2 kv_sort
292        
293         my $kvs = hash(a => 1, b => 2, c => 3)->kv_sort;
294         # $kvs = array(
295         # [ a => 1 ],
296         # [ b => 2 ],
297         # [ c => 3 ]
298         # )
299        
300         my $reversed = hash(a => 1, b => 2, c => 3)
301         ->kv_sort(sub { $_[1] cmp $_[0] });
302         # Reverse result as above
303        
304         Like L</kv>, but sorted by key. A sort routine can be provided; C<$_[0]> and
305         C<$_[1]> are equivalent to the usual sort variables C<$a> and C<$b>.
306        
307         =head2 set
308        
309         $hash->set(
310         key1 => $val,
311         key2 => $other,
312         )
313        
314         Sets keys in the hash.
315        
316         As of version 1.007, returns the current hash object.
317         The return value of prior versions is unreliable.
318        
319         =head2 sliced
320        
321         my $newhash = $hash->sliced(@keys);
322        
323         Returns a new hash object built from the specified set of keys.
324        
325         (See L</get> if you only need the values.)
326        
327         =head2 array_type
328        
329         The class name of array-type objects that will be used to contain the results
330         of methods returning a list.
331        
332         Defaults to L<List::Objects::WithUtils::Array>.
333        
334         Subclasses can override C<array_type> to produce different types of array
335         objects; the method can also be queried to find out what kind of array object
336         will be returned:
337        
338         my $type = $hash->array_type;
339        
340         =head2 inflated_type
341        
342         The class name that objects are blessed into when calling L</inflate>.
343        
344         Defaults to L<List::Objects::WithUtils::Hash::Inflated>.
345        
346         =head2 inflated_rw_type
347        
348         The class name that objects are blessed into when calling L</inflate> with
349         C<rw => 1>.
350        
351         Defaults to L<List::Objects::WithUtils::Hash::Inflated::RW>, a subclass of
352         L<List::Objects::WithUtils::Hash::Inflated>.
353        
354         =head1 SEE ALSO
355        
356         L<List::Objects::WithUtils>
357        
358         L<Data::Perl>
359        
360         =head1 AUTHOR
361        
362         Jon Portnoy <avenj@cobaltirc.org>
363        
364         Portions of this code are derived from L<Data::Perl> by Matthew Phillips
365         (CPAN: MATTP), haarg et al
366        
367         Licensed under the same terms as Perl.
368        
369         =cut
370