File Coverage

blib/lib/Set/Hash/Keys.pm
Criterion Covered Total %
statement 59 60 98.3
branch 16 18 88.8
condition n/a
subroutine 20 21 95.2
pod 7 7 100.0
total 102 106 96.2


line stmt bran cond sub pod time code
1             package Set::Hash::Keys;
2              
3 10     10   1056900 use strict;
  10         111  
  10         282  
4 10     10   59 use warnings;
  10         19  
  10         442  
5              
6             =head1 NAME
7              
8             Set::Hash::Keys - Treat Hashes as Sets, based on the keys only
9              
10             =head1 VERSION 0.02
11              
12             =cut
13              
14             our $VERSION = '0.02';
15              
16 10     10   80 use List::Util 'reduce';
  10         17  
  10         3408  
17              
18             =head1 SYNOPSIS
19              
20             use Set::Hash::Keys;
21            
22             my $set1 = Set::Hash::Keys->new(
23             foo => 'blue',
24             bar => 'july',
25             );
26              
27             or
28              
29             use Set::Hash::Keys;
30            
31             my $set2 = set_hash( foo => 'bike', baz => 'fish' );
32              
33             and later
34              
35             my $set3 = $set1 + $set2; # union
36             # foo => 'bike', # only the last remains
37             # bar => 'july',
38             # baz => 'fish',
39            
40             my $set4 = $set1 * $set2; # intersection
41             # foo => 'bike', # only the last remains
42            
43             my $set5 = $set1 - $set2; # difference
44             # bar => 'july',
45            
46             my ($sub1, $sub2) = $set1 / $set2; # exclusive or symmitrical difference
47            
48             my $set5 += { qux => 'moon', ... }; # add new elements
49             # bar => 'july',
50             # qux => 'moon',
51            
52             my $set3 -= { foo => 'sofa', ... };
53             # bar => 'july',
54             # baz => 'fish',
55            
56              
57             =head1 DESCRIPTION
58              
59             This module will help to check two or more hashes for which keys they have in
60             common and which not. It is all based on 'Set Theory' and works as expected. But
61             keep in mind that it only considders the keys to create unions, differences or
62             intersections. And that just like ordinary hash operations, the last key/value
63             pair wins.
64              
65             Other moules will treat operations in respect to the values too, and only will
66             do a difference or union if both key and value are the same in both hashes or.
67             sets.
68              
69             =cut
70              
71             use overload(
72 4 100   4   13810 q{+} => sub { pop @_ ? union($_[1],$_[0]) : union($_[0],$_[1]) },
73 4 100   4   4191 q{-} => sub { pop @_ ? difference($_[1],$_[0]) : difference($_[0],$_[1]) },
74 4 100   4   4196 q{*} => sub { pop @_ ? intersection($_[1],$_[0]) : intersection($_[0],$_[1]) },
75 0 0   0   0 q{/} => sub { pop @_ ? exclusive($_[1],$_[0]) : exclusive($_[0],$_[1]) },
76 4     4   4274 q{%} => sub { symmetrical($_[0],$_[1]) },
77 10     10   73 );
  10         30  
  10         139  
78              
79             =head1 IMPORTS
80              
81             For convenience, the C constructor has been imported in your current
82             namespace, so you can do:
83              
84             my $set_h = set_hash( foo => 'boat', bar => 'just' );
85              
86             All other functions mentioned below can be imported individually, or using the
87             C<:all> tag.
88              
89             =cut
90              
91 10     10   1343 use Exporter 'import';
  10         21  
  10         6428  
92              
93             our @EXPORT = qw (
94             &set_hash
95             );
96              
97             our @EXPORT_OK = qw (
98             &union
99             &intersection
100             &difference
101             &exclusive
102             &symmetrical
103             );
104              
105             our %EXPORT_TAGS = (
106             'all' => \@EXPORT_OK,
107             );
108              
109             sub set_hash {
110 1     1 1 2044 __PACKAGE__->new(@_)
111             }
112              
113             sub new {
114 93     93 1 75940 my $class = shift;
115 93         238 my %data = @_;
116            
117 93         318 return bless \%data, $class
118             }
119              
120             =head1 CONSTRUCTORS
121              
122             =cut
123              
124             =head2 new
125              
126             A class method to construct a new C-object
127              
128             my $set_h = Set::Hash::Keys->new(
129             foo => 'soap',
130             bar => 'blue',
131             );
132              
133             =cut
134              
135             =head2 set_hash
136              
137             A convenience function to construct a new C-object
138              
139             my $set_h = set_hash( foo => 'soap', bar => 'blue' );
140              
141             =cut
142              
143             =head1 SET OPERATIONS
144              
145             The following Set operations are provided as functions, that will take a list of
146             sets or HashRef's, or as binary (set) operators (that requires at least one of
147             the two being a L or as, or as an assignment operator. Usually
148             the function or set-operator will return a single L object. But
149             L, and L will return a list off object when evaluated in
150             list context. See below for how to use each and every set-operation.
151              
152             See L
153              
154             =cut
155              
156             =head2 union
157              
158             Based on the keys, this will produce a new unified L object
159             from the sets passed in.
160              
161             my $set_1 = union(
162             {
163             foo => 'blue',
164             bar => 'july',
165             },
166             {
167             foo => 'bike',
168             baz => 'fish',
169             },
170             {
171             qux => 'wood',
172             },
173             );
174             print values %$set_1; # july, fish, bike, wood
175            
176             my $set_2 = $set_1 + { bar => 'hand' };
177             print values %$set_2; # hand, fish, bike, wood
178            
179             $set_2 += { foo => 'wipe', xyz => 'bell' }
180             print values %$set_2; # hand, fish, wipe, wood, bell
181              
182             NOTE: like ordinary hashes, when using the same key more than once, the value of
183             the last one used will remain.
184              
185             =cut
186              
187             sub union {
188 18 100   18 1 15555 return unless defined $_[0];
189              
190             my $hash_ref = reduce {
191 19     19   35 +{ %{$a}, %{$b} }
  19         104  
  19         67  
192 16         99 } @_;
193            
194 16         52 __PACKAGE__->new( %{$hash_ref} );
  16         59  
195             }
196              
197             =head2 intersection
198              
199             The C will produce a L thas has all keys in
200             common.
201              
202             my $set_1 = intersection(
203             {
204             foo => 'blue',
205             bar => 'july',
206             },
207             {
208             foo => 'bike',
209             baz => 'fish',
210             },
211             {
212             qux => 'wood',
213             },
214             );
215             print values %$set_1; # bike
216            
217             my $set_2 = $set_1 * { foo => 'hand', qux => 'just' };
218             print values %$set_2; # hand
219            
220             $set_1 *= { foo => 'wipe', xyz => 'bell' }
221             print values %$set_1; # wipe
222              
223             NOTE: the value stored with any key, will be the value of the last set passed in
224              
225             =cut
226              
227             sub intersection {
228 8 100   8 1 14608 return unless defined $_[0];
229              
230             my $hash_ref = reduce {
231             +{
232             map {
233 8         35 $_ => $b->{$_}
234             } grep {
235 14         41 exists $b->{$_}
236 9     9   18 } keys %{$a}
  9         54  
237             }
238 7         53 } @_;
239            
240 7         35 __PACKAGE__->new( %{$hash_ref} );
  7         25  
241             }
242              
243             =head2 difference
244              
245             In scalar context, this will produce a set from the first set, minus all
246             key/value pairs mentioned after the first set.
247              
248             my $set_1 = difference(
249             {
250             foo => 'blue',
251             bar => 'july',
252             },
253             {
254             foo => 'bike',
255             baz => 'fish',
256             },
257             {
258             qux => 'wood',
259             },
260             );
261             print values %$set_1; # blue
262            
263             my $set_2 = $set_1 - { foo => 'hand', qux => 'just' };
264             print values %$set_2; # -
265            
266             $set_1 -= { foo => 'wipe', xyz => 'bell' }
267             print values %$set_1; # -
268              
269             In list context, this will produce a list of set, where the difference is
270             produced by taking each passed in set, minus all the key/values from the other
271             sets. And as such producing a list of sets that have unique values per set.
272              
273             my @diffs = difference(
274             {
275             foo => 'blue',
276             bar => 'july',
277             },
278             {
279             foo => 'bike',
280             baz => 'fish',
281             },
282             {
283             qux => 'wood',
284             },
285             );
286             print values %$diffs[0]; # july
287             print values %$diffs[1]; # fish
288             print values %$diffs[2]; # wood
289              
290             NOTE: it will retain the key/value pairs from the first set.
291              
292             =cut
293              
294             sub difference {
295 47 100   47 1 9084 return unless defined $_[0];
296            
297 43 100       93 if ( wantarray ) {
298 11         22 my $sets_ref = [];
299 11         44 for my $i ( 0 .. $#_ ) {
300 25         52 my @other = @_; # make a clone, since splice mutates it
301 25         48 my $set_i = splice @other, $i, 1 ;
302 25         81 my $set_d = difference( $set_i, @other );
303 25         67 push @{$sets_ref}, $set_d;
  25         67  
304             }
305 11         18 return @{$sets_ref}
  11         39  
306             }
307            
308             my $hash_ref = reduce {
309             +{
310             map {
311 45         173 $_ => $a->{$_}
312             } grep {
313 74         203 !exists $b->{$_}
314 43     43   85 } keys %{$a}
  43         189  
315             }
316 32         159 } @_;
317            
318 32         159 __PACKAGE__->new( %{$hash_ref} )
  32         103  
319             }
320              
321             =head2 exclusive
322              
323             In list context, this will produce a list of sets where each set will only
324             contain those key/value pairs that are exclusive to each set, in respect to the
325             other sets in the argument list.
326              
327             This is basicly the same as in list context.
328              
329             In scalar context, it will return the C of the before mentioned sets. So,
330             these key/value pairs are not mentioned in any other set.
331              
332             my $set_x = exclusive(
333             {
334             foo => 'blue',
335             bar => 'july',
336             },
337             {
338             foo => 'bike',
339             baz => 'fish',
340             },
341             {
342             qux => 'wood',
343             },
344             );
345             print values %$set_x # july, fish, wood
346              
347             my $set_1 = Set::Hash::Keys->new( foo => 'blue', bar => 'july' );
348            
349             my $set_2 = $set / { foo => 'bike' , baz => 'fish' }
350             print values %$set_2 # july, fish,
351            
352             $set_2 /= { qux => 'wood' };
353             print values %$set_2 # july, fish, wood
354            
355             # for liust context, see `difference`
356              
357             NOTE: for two sets, this basically produces the 'symmetrical difference'
358              
359             =cut
360              
361             sub exclusive {
362 5 100   5 1 2828 wantarray() ? difference( @_ ) : union( difference( @_ ) )
363             }
364              
365             =head2 symmetrical
366              
367             Produces the symmetrical difference from a list of sets. This is quite obvious
368             for two sets and returns those key/value pairs that are in either sets but not
369             in both.
370              
371             However, when passing in multiple sets, this gets confusing, but basically it
372             will hold those key/value pairs that have an odd count, even counts will not be
373             in the set. For more information see proper Set Theory explenation.
374              
375             As mentioned before, the symmetrical difference for two sets, is the same as the
376             union of the exclusive key/value pairs.
377              
378             my $set_s = symmetrical(
379             {
380             foo => 'blue',
381             bar => 'july',
382             },
383             {
384             foo => 'bike',
385             baz => 'fish',
386             },
387             {
388             foo => 'moon',
389             baz => 'wood',
390             },
391             print values %$set_1 # july, moon
392              
393             =cut
394              
395             sub symmetrical {
396 7     7   22 reduce { union ( difference( $a, $b ) ) } @_
397 7     7 1 1813 }
398              
399             =head1 AUTHOR
400              
401             Theo J. van Hoesel L
402              
403             =head1 COPYRIGHT AND LICENSE
404              
405             This software is copyright (c) 2018 by Theo J. van Hoesel - THEMA-MEDIA
406              
407             This is free software; you can redistribute it and/or modify it under the same
408             terms as the Perl 5 programming language system itself.
409              
410             Terms of the Perl programming language system itself
411              
412             a) the GNU General Public License as published by the Free Software Foundation;
413             either version 1, or (at your option) any later version, or
414             b) the "Artistic License"
415              
416             =cut
417              
418             1;