File Coverage

blib/lib/Set/DynamicGroups.pm
Criterion Covered Total %
statement 89 91 97.8
branch 30 36 83.3
condition 11 11 100.0
subroutine 17 17 100.0
pod 9 9 100.0
total 156 164 95.1


line stmt bran cond sub pod time code
1             # vim: set ts=2 sts=2 sw=2 expandtab smarttab:
2             #
3             # This file is part of Set-DynamicGroups
4             #
5             # This software is copyright (c) 2010 by Randy Stauner.
6             #
7             # This is free software; you can redistribute it and/or modify it under
8             # the same terms as the Perl 5 programming language system itself.
9             #
10 2     2   1825 use strict;
  2         5  
  2         91  
11 2     2   12 use warnings;
  2         4  
  2         119  
12              
13             package Set::DynamicGroups;
14             BEGIN {
15 2     2   52 $Set::DynamicGroups::VERSION = '0.014';
16             }
17             BEGIN {
18 2     2   67 $Set::DynamicGroups::AUTHORITY = 'cpan:RWSTAUNER';
19             }
20             # ABSTRACT: Manage groups of items dynamically
21              
22 2     2   14 use Carp qw(croak);
  2         4  
  2         2886  
23              
24             our %Aliases = (
25             in => 'include_groups',
26             items => 'include',
27             members => 'include',
28             'not' => 'exclude',
29             not_in => 'exclude_groups',
30             );
31              
32              
33             sub new {
34 2     2 1 138 my ($class) = @_;
35 2         6 my $self = {
36             groups => {},
37             };
38 2         9 bless $self, $class;
39             }
40              
41              
42             sub add {
43 32     32 1 503 my ($self) = shift;
44 32 50       91 my %groups = ref $_[0] ? %{$_[0]} : @_;
  0         0  
45 32         105 while( my ($name, $spec) = each %groups ){
46 32         72 $spec = $self->normalize($spec);
47 32   100     144 my $group = ($self->{groups}->{$name} ||= {});
48             # could use Hash::Merge, but this is a simple case:
49 32         88 while( my ($key, $val) = each %$spec ){
50 43   100     214 $self->_push_unique(($group->{$key} ||= []), {}, @$val);
51             }
52             }
53 32         81 return $self;
54             }
55              
56              
57             sub add_items {
58 4     4 1 9 my ($self, @append) = @_;
59              
60 4   100     24 my $items = ($self->{items} ||= []);
61 4 50       9 $self->_push_unique($items, {}, map { ref $_ ? @$_ : $_ } @append);
  7         23  
62 4         11 return scalar @$items;
63             }
64             *add_members = \&add_items;
65              
66             # NOTE: See L for comments
67              
68             sub _determine_items {
69             # $name is required (rathan than ref) to push name onto anti-recursion stack
70 147     147   172 my ($self, $name, $current) = @_;
71 147   100     431 $current ||= {};
72              
73             # avoid infinite recursion...
74             # 'each' strategy:
75 147 100       319 return []
76             if exists $current->{$name};
77 119         177 $current->{$name} = 1;
78              
79             # If the group doesn't exist just return an empty arrayref
80             # rather than autovivifying and filling with the wrong items, etc.
81 119 100       293 return []
82             unless my $group = $self->{groups}{$name};
83              
84 114         207 my @exclude = $self->_flatten_items($group, 'exclude', $current);
85              
86             # If no includes (only excludes) are specified,
87             # populate the list with all known items.
88             # Use _push_unique to maintain order (and uniqueness).
89 114         115 my @include;
90 114 100 100     456 $self->_push_unique(\@include, +{ map { $_ => 1 } @exclude },
  12         77  
91             (exists $group->{include} || exists $group->{include_groups})
92             ? $self->_flatten_items($group, 'include', $current)
93             : $self->items
94             );
95              
96 114         516 return \@include;
97             }
98              
99             sub _flatten_items {
100             # $group can currently be ref (rather than name)
101 217     217   288 my ($self, $group, $which, $current) = @_;
102 217 100       220 my @items = @{ $group->{ $which } || [] };
  217         726  
103 217 100       665 if( my $items = $group->{ "${which}_groups" } ){
104 67         82 my @flat = map { @{ $self->_determine_items($_, $current) } } @$items;
  75         66  
  75         635  
105 67         89 push(@items, @flat);
106             }
107 217         518 return @items;
108             }
109              
110              
111             sub group {
112 3     3 1 6 my ($self) = shift;
113 3 50       15 croak("group() requires a single argument. Perhaps you want groups().")
114             if @_ != 1;
115 3         6 my ($name) = @_;
116              
117 3 100       661 croak("Group $name is not defined")
118             unless exists $self->{groups}{$name};
119              
120             # get the value rather than a whole hash
121 2         5 my $items = $self->groups($name)->{$name};
122             # return a list (not an arrayref)
123 2         13 return @$items;
124             }
125              
126              
127             sub groups {
128 31     31 1 63 my ($self, @names) = @_;
129 31         38 my %groups;
130 31         36 my %group_specs = %{$self->{groups}};
  31         115  
131              
132             # if names provided, limit to those (and flatten), otherwise do all
133 9 50       32 @names = @names
134 31 100       165 ? map { ref $_ ? @$_ : $_ } @names
135             : keys %group_specs;
136              
137 31         59 foreach my $name ( @names ){
138             # the 'each' dependency resolution "strategy"
139 72         232 $groups{$name} = $self->_determine_items($name);
140             }
141              
142 31         243 return \%groups;
143             }
144              
145              
146             sub items {
147 14     14 1 703 my ($self) = @_;
148             # TODO: make it an option which things are included in this list?
149 14 100       11 my @items = @{ $self->{items} || [] };
  14         129  
150             # concatenate all items included in groups
151 45 100       297 $self->_push_unique(\@items, {},
152 45         44 map { @{ $_->{include} || [] } }
  14         32  
153 14         27 values %{ $self->{groups} });
154 14         70 return @items;
155             }
156             *members = \&items;
157              
158              
159             sub normalize {
160 32     32 1 38 my ($self, $spec) = @_;
161              
162             # if not a hashref, assume it's an (arrayref of) item(s)
163 32 100       89 $spec = {include => $spec}
164             unless ref $spec eq 'HASH';
165              
166             # TODO: croak if any unrecognized keys are present
167              
168 32         101 while( my ($alias, $name) = each %Aliases ){
169 160 100       543 if( exists($spec->{$alias}) ){
170 28 50       58 croak("Cannot include both an option and its alias: " .
171             "'$name' and '$alias' are mutually exclusive.")
172             if exists $spec->{$name};
173 28         105 $spec->{$name} = delete $spec->{$alias};
174             }
175             }
176              
177 32         91 while( my ($key, $value) = each %$spec ){
178             # convert scalar (string) to arrayref
179 43 100       178 $spec->{$key} = [$value]
180             unless ref $value;
181             }
182              
183 32         55 return $spec;
184             }
185              
186             sub _push_unique {
187 175     175   299 my ($self, $array, $seen, @push) = @_;
188              
189             # Ignore items already present.
190             # List assignment on a hash slice benches faster than: ++$s{$_} for @a
191 175         294 @$seen{ @$array } = (1) x @$array;
192              
193 175         220 push(@$array, grep { !$$seen{$_}++ } @push);
  266         1053  
194             }
195              
196              
197             sub set {
198 26     26 1 1003 my ($self) = shift;
199 26 50       704 my %groups = ref $_[0] ? %{$_[0]} : @_;
  0         0  
200 26         128 delete $self->{groups}{$_} foreach keys %groups;
201 26         79 $self->add(%groups);
202             }
203              
204              
205             sub set_items {
206 2     2 1 5 my ($self) = shift;
207 2         5 delete $self->{items};
208 2         6 return $self->add_items(@_);
209             }
210             *set_members = \&set_items;
211              
212             1;
213              
214              
215             __END__