File Coverage

blib/lib/List/Objects/WithUtils/Role/Hash.pm
Criterion Covered Total %
statement 152 152 100.0
branch 26 26 100.0
condition 8 10 80.0
subroutine 52 52 100.0
pod 34 36 94.4
total 272 276 98.5


line stmt bran cond sub pod time code
1             package List::Objects::WithUtils::Role::Hash;
2             $List::Objects::WithUtils::Role::Hash::VERSION = '2.028002';
3 136     136   62371 use strictures 2;
  136         3090  
  136         5163  
4              
5 136     136   34263 use Module::Runtime ();
  136         44795  
  136         1792  
6 136     136   453 use Scalar::Util ();
  136         130  
  136         1336  
7 136     136   397 use List::Util ();
  136         126  
  136         9184  
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 56 100   56 0 385 Scalar::Util::blessed($_[0]) ?
16             $_[0] : Module::Runtime::use_module(HASH_TYPE)
17             }
18              
19 136     136   448 use Role::Tiny;
  136         154  
  136         635  
20              
21 126     126 1 579 sub array_type { 'List::Objects::WithUtils::Array' }
22 4     4 1 21 sub inflated_type { 'List::Objects::WithUtils::Hash::Inflated' }
23 2     2 1 12 sub inflated_rw_type { 'List::Objects::WithUtils::Hash::Inflated::RW' }
24              
25             =for Pod::Coverage TO_JSON TO_ZPL damn type
26              
27             =cut
28              
29 2     2 1 8 sub is_mutable { 1 }
30 2     2 1 20 sub is_immutable { ! $_[0]->is_mutable }
31              
32       2 0   sub type { }
33              
34             our %Required;
35             sub new {
36 75     75 1 288 my $arraytype = $_[0]->array_type;
37             $Required{$arraytype} = Module::Runtime::require_module($arraytype)
38 75 100       368 unless exists $Required{$arraytype};
39 75   66     1526 bless +{ @_[1 .. $#_] }, Scalar::Util::blessed($_[0]) || $_[0]
40             }
41              
42 13     13 1 723 sub export { %{ $_[0] } }
  13         120  
43 16     16 1 2562 sub unbless { +{ %{ $_[0] } } }
  16         79  
44              
45 136     136   37322 { no warnings 'once';
  136         182  
  136         13394  
46             *TO_JSON = *unbless;
47             *TO_ZPL = *unbless;
48             *damn = *unbless;
49             }
50              
51 1     1 1 5 sub clear { %{ $_[0] } = (); $_[0] }
  1         5  
  1         5  
52              
53             =for Pod::Coverage untyped
54              
55             =cut
56              
57 4     4 1 24 sub copy { blessed_or_pkg($_[0])->new(%{ $_[0] }) }
  4         46  
58 136     136   516 { no warnings 'once'; *untyped = *copy; }
  136         175  
  136         44889  
59              
60             sub inflate {
61 3     3 1 16 my ($self, %params) = @_;
62 3 100       8 my $type = $params{rw} ? 'inflated_rw_type' : 'inflated_type';
63 3         8 my $cls = blessed_or_pkg($self);
64 3         36 Module::Runtime::require_module( $cls->$type );
65 3         13 $cls->$type->new( %$self )
66             }
67              
68 6     6 1 44 sub defined { CORE::defined $_[0]->{ $_[1] } }
69 10     10 1 710 sub exists { CORE::exists $_[0]->{ $_[1] } }
70              
71 4     4 1 15 sub is_empty { ! keys %{ $_[0] } }
  4         24  
72              
73             sub get {
74 49 100   49 1 10593 if (@_ > 2) {
75             return blessed_or_pkg($_[0])->array_type->new(
76 2         7 @{ $_[0] }{ @_[1 .. $#_] }
  2         16  
77             )
78             }
79 47         215 $_[0]->{ $_[1] }
80             }
81              
82             sub get_or_else {
83 10 100 100 10 1 125 exists $_[0]->{ $_[1] } ? $_[0]->{ $_[1] }
    100          
84             : (Scalar::Util::reftype $_[2] || '') eq 'CODE' ? $_[2]->(@_[0,1])
85             : $_[2]
86             }
87              
88             sub get_path {
89 11     11 1 368 my $ref = $_[0];
90 11         23 for my $part (@_[1 .. $#_]) {
91 25 100       51 $ref = ref $part eq 'ARRAY' ? $ref->[ $part->[0] ] : $ref->{$part};
92 23 100       43 return undef unless defined $ref;
93             }
94             $ref
95 6         18 }
96              
97             =for Pod::Coverage slice
98              
99             =cut
100              
101 136     136   565 { no warnings 'once'; *slice = *sliced; }
  136         155  
  136         71696  
102             { local $@;
103             if ($] >= 5.020) {
104 4     4 1 123 eval q[
  4         25  
  11         74  
105             sub sliced {
106             blessed_or_pkg($_[0])->new(
107             %{ $_[0] }{ grep {; exists $_[0]->{$_} } @_[1 .. $#_] }
108             )
109             }
110             ];
111             } else {
112             eval q[
113             sub sliced {
114             blessed_or_pkg($_[0])->new(
115             map {; exists $_[0]->{$_} ? ($_ => $_[0]->{$_}) : () }
116             @_[1 .. $#_]
117             )
118             }
119             ];
120             }
121             die "installing sub 'sliced' died: $@" if $@;
122             }
123              
124             sub set {
125 9     9 1 743 my $self = shift;
126 9         11 my (@keysidx, @valsidx);
127 9 100       58 $_ % 2 ? push @valsidx, $_ : push @keysidx, $_ for 0 .. $#_;
128 9         19 @{$self}{ @_[@keysidx] } = @_[@valsidx];
  9         29  
129 8         38 $self
130             }
131              
132             sub maybe_set {
133 2     2 1 21 my $self = shift;
134 2         6 for (grep {; not $_ % 2 } 0 .. $#_) {
  12         16  
135 6 100       21 $self->{ $_[$_] } = $_[$_ + 1] unless exists $self->{ $_[$_] }
136             }
137             $self
138 2         10 }
139              
140             sub delete {
141             blessed_or_pkg($_[0])->array_type->new(
142 4     4 1 27 CORE::delete @{ $_[0] }{ @_[1 .. $#_] }
  4         22  
143             )
144             }
145              
146             sub keys {
147             blessed_or_pkg($_[0])->array_type->new(
148 10     10 1 958 CORE::keys %{ $_[0] }
  10         76  
149             )
150             }
151              
152             sub values {
153             blessed_or_pkg($_[0])->array_type->new(
154 2     2 1 25 CORE::values %{ $_[0] }
  2         16  
155             )
156             }
157              
158             sub intersection {
159 3     3 1 33 my %seen; my %inner;
160             blessed_or_pkg($_[0])->array_type->new(
161 8         25 grep {; not $seen{$_}++ }
162 3         8 grep {; ++$inner{$_} > $#_ } map {; CORE::keys %$_ } @_
  49         58  
  8         27  
163             )
164             }
165              
166             sub diff {
167 3     3 1 41 my %seen; my %inner;
168 3         5 my @vals = map {; CORE::keys %$_ } @_;
  7         22  
169 3         15 $seen{$_}++ for @vals;
170             blessed_or_pkg($_[0])->array_type->new(
171 19         31 grep {; $seen{$_} != @_ }
172 3         9 grep {; not $inner{$_}++ } @vals
  28         30  
173             )
174             }
175              
176             sub iter {
177 3     3 1 25 my @list = %{ $_[0] };
  3         21  
178 9     9   46 sub { splice @list, 0, 2 }
179 3         17 }
180              
181             sub kv {
182             blessed_or_pkg($_[0])->array_type->new(
183 2     2 1 25 map {; [ $_, $_[0]->{ $_ } ] } CORE::keys %{ $_[0] }
  4         18  
  2         10  
184             )
185             }
186              
187             sub kv_sort {
188 10 100 66 10 1 783 if (defined $_[1] && (my $cb = $_[1])) {
189 6         13 my $pkg = caller;
190 136     136   603 no strict 'refs';
  136         145  
  136         22830  
191             return blessed_or_pkg($_[0])->array_type->new(
192 15         59 map {; [ $_, $_[0]->{ $_ } ] } sort {;
193 15         73 local (*{"${pkg}::a"}, *{"${pkg}::b"}) = (\$a, \$b);
  15         25  
  15         25  
194 15         27 $a->$cb($b)
195 6         16 } CORE::keys %{ $_[0] }
  6         44  
196             )
197             }
198             blessed_or_pkg($_[0])->array_type->new(
199 4         8 map {; [ $_, $_[0]->{ $_ } ] } sort( CORE::keys %{ $_[0] } )
  16         32  
  4         22  
200             )
201             }
202              
203             sub kv_map {
204 3     3 1 28 my ($self, $cb) = @_;
205 3         6 my $pkg = caller;
206 136     136   609 no strict 'refs';
  136         165  
  136         15421  
207             blessed_or_pkg($self)->array_type->new(
208             List::Util::pairmap {;
209 9     9   25 local (*{"${pkg}::a"}, *{"${pkg}::b"}) = (\$a, \$b);
  9         15  
  9         13  
210 9         16 $a->$cb($b)
211 3         8 } %$self
212             )
213             }
214              
215             sub kv_grep {
216 3     3 1 28 my ($self, $cb) = @_;
217 3         5 my $pkg = caller;
218 136     136   534 no strict 'refs';
  136         157  
  136         22471  
219             blessed_or_pkg($self)->new(
220             List::Util::pairgrep {;
221 9     9   71 local (*{"${pkg}::a"}, *{"${pkg}::b"}) = (\$a, \$b);
  9         17  
  9         13  
222 9         15 $a->$cb($b)
223 3         9 } %$self
224             )
225             }
226              
227             =for Pod::Coverage invert
228              
229             =cut
230              
231             sub inverted {
232 3     3 1 25 my ($self) = @_;
233 3         9 my $cls = blessed_or_pkg($self);
234 3         34 my %new;
235             List::Util::pairmap {;
236             exists $new{$b} ?
237 12 100   12   42 $new{$b}->push($a) : ( $new{$b} = $cls->array_type->new($a) )
238 3         49 } %$self;
239 3         21 $cls->new(%new)
240             }
241 136     136   540 { no warnings 'once'; *invert = *inverted; }
  136         150  
  136         31071  
242              
243              
244             sub random_kv {
245 2     2 1 4 my $key = (CORE::keys %{ $_[0] })[rand CORE::keys %{ $_[0] }];
  2         5  
  2         38  
246 2 100       9 $key ? [ $key => $_[0]->{$key} ] : undef
247             }
248              
249             sub random_key {
250 2   100 2 1 6 (CORE::keys %{ $_[0] })[rand (CORE::keys %{ $_[0] } || return undef)]
  1         6  
251             }
252              
253             sub random_value {
254 2     2 1 6 [@_ = %{ $_[0] }]->[1|rand @_]
  2         42  
255             }
256              
257              
258             print
259             qq[ huf: I learned that from toyota via agile blahblah,],
260             qq[ it's asking the five "why" questions.\n],
261             qq[ WHY WHY WHY WHY GOD WHY\n]
262             unless caller;
263             1;
264              
265              
266             =pod
267              
268             =head1 NAME
269              
270             List::Objects::WithUtils::Role::Hash - Hash manipulation methods
271              
272             =head1 SYNOPSIS
273              
274             ## Via List::Objects::WithUtils::Hash ->
275             use List::Objects::WithUtils 'hash';
276              
277             my $hash = hash(foo => 'bar');
278              
279             $hash->set(
280             foo => 'baz',
281             pie => 'tasty',
282             );
283              
284             my @matches = $hash->keys->grep(sub { $_[0] =~ /foo/ })->all;
285              
286             my $pie = $hash->get('pie')
287             if $hash->exists('pie');
288              
289             for my $pair ( $hash->kv->all ) {
290             my ($key, $val) = @$pair;
291             ...
292             }
293              
294             my $obj = $hash->inflate;
295             my $foo = $obj->foo;
296              
297             ## As a Role ->
298             use Role::Tiny::With;
299             with 'List::Objects::WithUtils::Role::Hash';
300              
301             =head1 DESCRIPTION
302              
303             A L role defining methods for creating and manipulating HASH-type
304             objects.
305              
306             In addition to the methods documented below, these objects provide a
307             C method exporting a plain HASH-type reference for convenience when
308             feeding L or similar, as well as a C method for
309             compatibility with L.
310              
311             =head2 Basic hash methods
312              
313             =head3 new
314              
315             Constructs a new HASH-type object.
316              
317             =head3 copy
318              
319             Creates a shallow clone of the current object.
320              
321             =head3 defined
322              
323             if ( $hash->defined($key) ) { ... }
324              
325             Returns boolean true if the key has a defined value.
326              
327             =head3 exists
328              
329             if ( $hash->exists($key) ) { ... }
330              
331             Returns boolean true if the key exists.
332              
333             =head3 export
334              
335             my %hash = $hash->export;
336              
337             Returns a raw key => value list.
338              
339             For a plain HASH-type reference, see: L
340              
341             =head3 array_type
342              
343             The class name of array-type objects that will be used to contain the results
344             of methods returning a list.
345              
346             Defaults to L.
347              
348             Subclasses can override C to produce different types of array
349             objects.
350              
351             =head3 inflate
352              
353             my $obj = hash(foo => 'bar', baz => 'quux')->inflate;
354             my $baz = $obj->baz;
355              
356             Inflates the hash-type object into a simple struct-like object with accessor
357             methods matching the keys of the hash.
358              
359             By default, accessors are read-only; specifying C 1> allows setting new
360             values:
361              
362             my $obj = hash(foo => 'bar', baz => 'quux')->inflate(rw => 1);
363             $obj->foo('frobulate');
364              
365             Returns an L (or L) object.
366              
367             The default objects provide a C method returning a
368             plain hash; this makes it easy to turn inflated objects back into a C
369             for modification:
370              
371             my $first = hash( foo => 'bar', baz => 'quux' )->inflate;
372             my $second = hash( $first->DEFLATE, frobulate => 1 )->inflate;
373              
374             =head3 inflated_type
375              
376             The class that objects are blessed into when calling L.
377              
378             Defaults to L.
379              
380             =head3 inflated_rw_type
381              
382             The class that objects are blessed into when calling L with
383             C 1> specified.
384              
385             Defaults to L, a subclass of
386             L.
387              
388             =head3 is_empty
389              
390             Returns boolean true if the hash has no keys.
391              
392             =head3 is_mutable
393              
394             Returns boolean true if the hash is mutable; immutable subclasses can override
395             to provide a negative value.
396              
397             =head3 is_immutable
398              
399             The opposite of L.
400              
401             =head3 unbless
402              
403             Returns a plain C reference (shallow clone).
404              
405             =head2 Methods that manipulate the hash
406              
407             =head3 clear
408              
409             Clears the current hash entirely.
410              
411             Returns the (same, but now empty) hash object.
412              
413             =head3 delete
414              
415             $hash->delete(@keys);
416              
417             Deletes the given key(s) from the hash.
418              
419             Returns an L object containing the deleted values.
420              
421             =head3 set
422              
423             $hash->set(
424             key1 => $val,
425             key2 => $other,
426             )
427              
428             Sets keys in the hash.
429              
430             Returns the current hash object.
431              
432             =head3 maybe_set
433              
434             my $hash = hash(foo => 1, bar => 2, baz => 3);
435             $hash->maybe_set(foo => 2, bar => 3, quux => 4);
436             # $hash = +{ foo => 1, bar => 2, baz => 3, quux => 4 }
437              
438             Like L, but only sets values that do not already exist in the hash.
439              
440             Returns the current hash object.
441              
442             =head2 Methods that retrieve items
443              
444             =head3 get
445              
446             my $val = $hash->get($key);
447             my @vals = $hash->get(@keys)->all;
448              
449             Retrieves a key or list of keys from the hash.
450              
451             If taking a slice (multiple keys were specified), values are returned
452             as an L object. (See L if you'd rather generate a new
453             hash.)
454              
455             =head3 get_path
456              
457             my $hash = hash(
458             foo => +{ bar => +{ baz => 'bork' } },
459             quux => [ +{ weeble => 'snork' } ],
460             );
461             my $item = $hash->get_path(qw/foo bar baz/); # 'bork'
462              
463             Attempt to retrieve a value from a 'deep' hash (without risking
464             autovivification).
465              
466             If an element of the given path is a (plain) array reference, as in this
467             example:
468              
469             my $item = $hash->get_path('quux', [1], 'weeble'); # "snork"
470              
471             ... then it is taken as the index of an array or array-type object in the
472             path.
473              
474             Returns undef if any of the path elements are nonexistant.
475            
476             An exception is thrown if an invalid access is attempted, such as trying to
477             use a hash-type object as if it were an array.
478              
479             (Available from v2.15.1)
480              
481             =head3 get_or_else
482              
483             # Expect to find an array() obj at $key in $hash,
484             # or create an empty one if $key doesn't exist:
485             my @all = $hash->get_or_else($key => array)->all;
486              
487             # Or pass a coderef
488             # First arg is the object being operated on
489             # Second arg is the requested key
490             my $item = $hash->get_or_else($key => sub { shift->get($defaultkey) });
491              
492             Retrieves a key from the hash; optionally takes a second argument that is used
493             as a default value if the given key does not exist in the hash.
494              
495             If the second argument is a coderef, it is invoked on the object (with the
496             requested key as an argument) and its return value is taken as the default
497             value.
498              
499             =head3 keys
500              
501             my @keys = $hash->keys->all;
502              
503             Returns the list of keys in the hash as an L object.
504              
505             =head3 values
506              
507             my @vals = $hash->values->all;
508              
509             Returns the list of values in the hash as an L object.
510              
511             =head3 inverted
512              
513             my $hash = hash(
514             a => 1,
515             b => 2,
516             c => 2,
517             d => 3
518             );
519             my $newhash = $hash->inverted;
520             # $newhash = +{
521             # 1 => array('a'),
522             # 2 => array('b', 'c'),
523             # 3 => array('d'),
524             # }
525              
526             Inverts the hash; the values of the original hash become keys in the new
527             object. Their corresponding values are L objects containing the
528             key(s) that mapped to the original value.
529              
530             This is a bit like reversing the hash, but lossless with regards to non-unique
531             values.
532              
533             (Available from v2.14.1)
534              
535             =head3 iter
536              
537             my $iter = $hash->iter;
538             while (my ($key, $val) = $iter->()) {
539             # ...
540             }
541              
542             Returns an iterator that, when called, returns ($key, $value) pairs.
543             When the list is exhausted, an empty list is returned.
544              
545             The iterator operates on a shallow clone of the hash, making it safe to
546             operate on the original hash while using the iterator.
547              
548             (Available from v2.9.1)
549              
550             =head3 kv
551              
552             for my $pair ($hash->kv->all) {
553             my ($key, $val) = @$pair;
554             }
555              
556             Returns an L object containing the key/value pairs in the hash,
557             each of which is a two-element (unblessed) ARRAY.
558              
559             =head3 kv_grep
560              
561             my $positive_vals = $hash->kv_grep(sub { $b > 0 });
562              
563             Like C, but operates on pairs. See L.
564              
565             Returns a hash-type object consisting of the key/value pairs for which the
566             given block returned true.
567              
568             (Available from v2.21.1)
569              
570             =head3 kv_map
571              
572             # Add 1 to each value, get back an array-type object:
573             my $kvs = hash(a => 2, b => 2, c => 3)
574             ->kv_map(sub { ($a, $b + 1) });
575              
576             Like C, but operates on pairs. See L.
577              
578             Returns an L object containing the results of the map.
579              
580             (Available from v2.8.1; in versions prior to v2.20.1, C<$_[0]> and C<$_[1]>
581             must be used in place of C<$a> and C<$b>, respectively.)
582              
583             =head3 kv_sort
584              
585             my $kvs = hash(a => 1, b => 2, c => 3)->kv_sort;
586             # $kvs = array(
587             # [ a => 1 ],
588             # [ b => 2 ],
589             # [ c => 3 ]
590             # )
591              
592             my $reversed = hash(a => 1, b => 2, c => 3)
593             ->kv_sort(sub { $b cmp $a });
594             # Reverse result as above
595              
596             Like L, but sorted by key. A sort routine can be provided.
597              
598             In versions prior to v2.19.1, C<$_[0]> and C<$_[1]> must be used in place of
599             C<$a> and C<$b>, respectively.
600              
601             =head3 random_kv
602              
603             Returns a random key/value pair from the hash as an C-type reference.
604              
605             Returns undef if the hash is empty.
606              
607             (Available from v2.28.1)
608              
609             =head3 random_key
610              
611             Returns a random key from the hash.
612              
613             Returns undef if the hash is empty.
614              
615             (Available from v2.28.1)
616              
617             =head3 random_value
618              
619             Returns a random value from the hash.
620              
621             Returns undef if the hash is empty.
622              
623             (Available from v2.28.1)
624              
625             =head3 sliced
626              
627             my $newhash = $hash->sliced(@keys);
628              
629             Returns a new hash object built from the specified set of keys and their
630             respective values.
631              
632             If a given key is not found in the hash, it is omitted from the result (this
633             is different than C hash slice syntax, which sets unknown keys to
634             C in the slice).
635              
636             If you only need the values, see L.
637              
638             =head2 Methods that compare hashes
639              
640             =head3 intersection
641              
642             my $first = hash(a => 1, b => 2, c => 3);
643             my $second = hash(b => 2, c => 3, d => 4);
644             my $intersection = $first->intersection($second);
645             my @common = $intersection->sort->all;
646              
647             Returns the list of keys common between all given hash-type objects (including
648             the invocant) as an L object.
649              
650             =head3 diff
651              
652             The opposite of L; returns the list of keys that are not common
653             to all given hash-type objects (including the invocant) as an L
654             object.
655              
656             =head1 NOTES FOR CONSUMERS
657              
658             If creating your own consumer of this role, some extra effort is required to
659             make C<$a> and C<$b> work in sort statements without warnings; an example with
660             a custom exported constructor might look something like:
661              
662             package My::Custom::Hash;
663             use strictures 2;
664             require Role::Tiny;
665             Role::Tiny->apply_roles_to_package( __PACKAGE__,
666             qw/
667             List::Objects::WithUtils::Role::Hash
668             My::Custom::Hash::Role
669             /
670             );
671              
672             use Exporter ();
673             our @EXPORT = 'myhash';
674             sub import {
675             my $pkg = caller;
676             { no strict 'refs';
677             ${"${pkg}::a"} = ${"${pkg}::a"};
678             ${"${pkg}::b"} = ${"${pkg}::b"};
679             }
680             goto &Exporter::import
681             }
682              
683             sub myhash { __PACKAGE__->new(@_) }
684              
685             =head1 SEE ALSO
686              
687             L
688              
689             L
690              
691             L
692              
693             L
694              
695             L
696              
697             =head1 AUTHOR
698              
699             Jon Portnoy
700              
701             Portions of this code are derived from L by Matthew Phillips
702             (CPAN: MATTP), haarg et al
703              
704             Licensed under the same terms as Perl.
705              
706             =cut