File Coverage

blib/lib/Set/Intersection.pm
Criterion Covered Total %
statement 27 27 100.0
branch 8 8 100.0
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 40 40 100.0


line stmt bran cond sub pod time code
1             package Set::Intersection;
2              
3 4     4   65511 use warnings;
  4         8  
  4         144  
4 4     4   19 use strict;
  4         5  
  4         1429  
5              
6             =head1 NAME
7              
8             Set::Intersection - provides an API to get intersection (of set theory) of ARRAYs.
9              
10             =head1 VERSION
11              
12             Version 0.04;
13              
14             =cut
15              
16             our $VERSION = '0.04';
17              
18              
19             =head1 SYNOPSIS
20              
21             use Set::Intersection;
22              
23             my @arr1 = qw/3 1 4 1 5 9/;
24             my @arr2 = qw/1 7 3 2 0 5/;
25             my @intersection = get_intersection(\@arr1, \@arr2);
26             # got (1, 3, 5) in @intersection
27              
28             =head1 EXPORT
29              
30             get_intersection
31              
32             =cut
33              
34             require Exporter;
35             our @ISA = qw/Exporter/;
36              
37             our @EXPORT = qw/get_intersection/;
38              
39             =head1 FUNCTIONS
40              
41             =head2 C
42              
43             get_intersection([\%options,] [\@ARRAY[, \@ARRAY[, ...]]]);
44              
45             Returns intersection set (as LIST) of all ARRAYs.
46              
47             =over 4
48              
49             =item *
50              
51             The result LIST is uniqued and unordered.
52              
53             =item *
54              
55             If no ARRAYs are passed, the result LIST is empty.
56              
57             =item *
58              
59             If only one ARRAY is passed, the result LIST is same as that passed. (In this
60             case, elements won't be uniqued nor will the order bechanged.)
61              
62             =item *
63              
64             If you have C in any LIST, you'll be warned.
65              
66             =back
67              
68             =head3 C<%options>
69              
70             -preordered => BOOLEAN
71              
72             To reduce calculation time, C sorts ARRAYs
73             by their length before calculating intersections.
74              
75             This option tells that order of ARRAYs are well done,
76             and calculation of intersection will be based on left most ARRAY.
77              
78             =cut
79              
80             my %_default_opts = (
81             -preordered => 0,
82             );
83              
84             sub get_intersection
85             {
86 12     12 1 9026 my %opts;
87 12 100       43 if ( ref($_[0]) =~ m{^HASH} ) {
88 1         3 %opts = (%_default_opts, %{$_[0]});
  1         3  
89 1         2 shift;
90             }
91              
92 12         18 my @arrs = @_;
93 12 100       28 return () if !@arrs;
94 11 100       25 return @{$arrs[0]} if @arrs == 1;
  1         5  
95              
96 10 100       50 @arrs = sort { @$a <=> @$b } @arrs if !$opts{-preordered};
  17         29  
97              
98 10         13 my $head = shift @arrs;
99              
100 10         24 _intersection($head, @arrs);
101             }
102              
103             sub _intersection
104             {
105 10     10   12 my ($head, @left) = @_;
106              
107 10         19 my %h = map { $_ => undef } @$head;
  40         92  
108 10         24 for my $l ( @left ) {
109 15         18 %h = map { $_ => undef } grep { exists $h{$_} } @$l;
  27         107  
  79         99  
110             }
111 10         55 keys %h;
112             }
113              
114             =head1 SEE ALSO
115              
116             List::Compare, Set::Object
117              
118             =head1 AUTHOR
119              
120             turugina, C<< >>
121              
122             =head1 BUGS
123              
124             Please report any bugs or feature requests to C, or through
125             the web interface at L. I will be notified, and then you'll
126             automatically be notified of progress on your bug as I make changes.
127              
128              
129              
130              
131             =head1 SUPPORT
132              
133             You can find documentation for this module with the perldoc command.
134              
135             perldoc Set::Intersection
136              
137             You can also look for information at:
138              
139             =over 4
140              
141             =item * RT: CPAN's request tracker
142              
143             L
144              
145             =item * AnnoCPAN: Annotated CPAN documentation
146              
147             L
148              
149             =item * CPAN Ratings
150              
151             L
152              
153             =item * Search CPAN
154              
155             L
156              
157             or
158              
159             L
160              
161             =back
162              
163              
164             =head1 ACKNOWLEDGEMENTS
165              
166             =head1 COPYRIGHT & LICENSE
167              
168             Copyright 2009 turugina, all rights reserved.
169              
170             This program is free software; you can redistribute it and/or modify it
171             under the same terms as Perl itself.
172              
173              
174             =cut
175              
176             1; # End of Set::Intersection
177