File Coverage

blib/lib/Circle/Collection.pm
Criterion Covered Total %
statement 94 201 46.7
branch 33 80 41.2
condition 13 49 26.5
subroutine 7 19 36.8
pod n/a
total 147 349 42.1


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk
4              
5             package Circle::Collection;
6              
7 4     4   20 use strict;
  4         6  
  4         116  
8 4     4   18 use warnings;
  4         5  
  4         112  
9              
10 4     4   18 use Carp;
  4         6  
  4         294  
11             require attributes;
12              
13 4     4   20 use Attribute::Storage qw( apply_subattrs_for_pkg );
  4         4  
  4         36  
14 4     4   247 use Class::Method::Modifiers qw( install_modifier );
  4         6  
  4         6607  
15              
16             # A template role to merge
17             sub import
18             {
19 16     16   31 my $pkg = shift;
20 16         62 my %args = @_;
21              
22 16         35 my $caller = caller;
23              
24 16 50       72 my $name = $args{name} or croak "Need a collection name";
25              
26 16 50       43 my $attrs = $args{attrs} or croak "Need attrs";
27 16 50       53 ref $attrs eq "ARRAY" or croak "Expected 'attrs' to be an ARRAY";
28              
29 16   33     86 my $desc2 = $args{desc_plural} || $name;
30 16   33     63 my $desc1 = $args{desc_single} || do { $_ = $name; s/s$//; $_ };
31              
32 16 50       40 my $storage = $args{storage} or croak "Need a storage type";
33 16         25 my $config = $args{config};
34              
35             # Now parse it down to several fields
36 16         22 my @attrs_all;
37             my @attrs_persisted;
38 0         0 my %attrs;
39              
40 16         49 for( my $i = 0; $i < @$attrs; $i += 2 ) {
41 52         53 my $name = $attrs->[$i];
42 52         53 my $a = $attrs->[$i+1];
43              
44 52         54 push @attrs_all, $name;
45 52 100       99 push @attrs_persisted, $name unless $a->{transient};
46              
47 52         119 $attrs{$name} = $a;
48             }
49              
50 16         24 my $keyattr = $attrs_all[0];
51              
52 16         20 my %commands;
53 16 100       37 %commands = %{ $args{commands} } if $args{commands};
  4         22  
54              
55             # Data access code
56              
57 16         21 my ( $method_list, $method_get, $method_set, $method_add, $method_del );
58              
59 16 100       150 if( ref $storage eq "HASH" ) {
    100          
    50          
60 8         12 $method_list = $storage->{list};
61 8         10 $method_get = $storage->{get};
62 8         8 $method_set = $storage->{set};
63 8         8 $method_add = $storage->{add};
64 8         10 $method_del = $storage->{del};
65             }
66             elsif( $storage eq "methods" ) {
67 4         12 $method_list = "${name}_list";
68 4         9 $method_get = "${name}_get";
69 4         9 $method_set = "${name}_set";
70 4         7 $method_add = "${name}_add";
71 4         7 $method_del = "${name}_del";
72             }
73             elsif( $storage eq "array" ) {
74             $method_list = sub {
75 0     0   0 my $self = shift;
76 0         0 return @{ $self->{$name} }
  0         0  
77 4         17 };
78              
79             $method_get = sub {
80 0     0   0 my $self = shift;
81 0         0 my ( $key ) = @_;
82 0         0 return ( grep { $_->{$keyattr} eq $key } @{ $self->{$name} } )[0];
  0         0  
  0         0  
83 4         16 };
84              
85             $method_add = sub {
86 0     0   0 my $self = shift;
87 0         0 my ( $key, $item ) = @_;
88             # TODO: something with key
89 0         0 push @{ $self->{$name} }, $item;
  0         0  
90 4         16 };
91              
92             $method_del = sub {
93 0     0   0 my $self = shift;
94 0         0 my ( $key, $item ) = @_;
95              
96 0         0 my $items = $self->{$name};
97 0         0 my ( $idx ) = grep { $items->[$_] == $item } 0 .. $#$items;
  0         0  
98              
99 0 0       0 return 0 unless defined $idx;
100              
101 0         0 splice @$items, $idx, 1, ();
102 0         0 return 1;
103 4         16 };
104             }
105             else {
106 0         0 croak "Unrecognised storage type $storage";
107             }
108              
109             # Manipulation commands
110              
111 16 50       40 unless( exists $commands{list} ) {
112 16 50       41 defined $method_list or croak "No list method defined for list subcommand";
113              
114             $commands{list} = apply_subattrs_for_pkg( $caller,
115             Command_description => qq("List the $desc2"),
116             Command_subof => qq('$name'),
117             Command_default => qq(),
118             sub {
119 0     0   0 my $self = shift;
120 0         0 my ( $cinv ) = @_;
121              
122 0         0 my @items = $self->$method_list;
123              
124 0 0       0 unless( @items ) {
125 0         0 $cinv->respond( "No $desc2" );
126 0         0 return;
127             }
128              
129 0         0 my @table;
130              
131 0         0 foreach my $item ( @items ) {
132 0         0 my @shown_item;
133 0         0 foreach my $attr ( @attrs_all ) {
134 0         0 my $value = $item->{$attr};
135 0 0       0 push @shown_item, exists $attrs{$attr}{show} ? $attrs{$attr}{show}->( local $_ = $value ) : $value;
136             }
137 0         0 push @table, \@shown_item;
138             }
139              
140 0         0 $cinv->respond_table( \@table, headings => \@attrs_all );
141 0         0 return;
142             }
143 16         156 );
144             }
145              
146 16         834 my @opts_add;
147             my @opts_mod;
148              
149 16         31 foreach ( @attrs_persisted ) {
150 48 100       93 next if $_ eq $keyattr;
151              
152 32   66     84 my $desc = $attrs{$_}{desc} || $_;
153              
154 32 100       79 $desc .= qq[ (default \\"$attrs{$_}{default}\\")] if exists $attrs{$_}{default};
155              
156 32         89 push @opts_add, qq('$_=\$', desc => "$desc");
157              
158             push @opts_mod, qq('$_=\$', desc => "$desc"),
159 32 100       138 qq('no-$_=+', desc => "remove $_") unless $attrs{$_}{nomod};
160             }
161              
162 16 100       48 unless( exists $commands{add} ) {
163 12 50       25 defined $method_add or croak "No add method defined for add subcommand";
164              
165             $commands{add} = apply_subattrs_for_pkg( $caller,
166             Command_description => qq("Add a $desc1"),
167             Command_subof => qq('$name'),
168             Command_arg => qq('$keyattr'),
169 28         176 ( map { +Command_opt => $_ } @opts_add ),
170             sub {
171 0     0   0 my $self = shift;
172 0         0 my ( $key, $opts, $cinv ) = @_;
173              
174 0 0       0 if( $self->$method_get( $key ) ) {
175 0         0 $cinv->responderr( "Already have a $desc1 '$key'" );
176 0         0 return;
177             }
178              
179 0         0 my $item = { $keyattr => $key };
180 0   0     0 exists $attrs{$_}{default} and $item->{$_} = $attrs{$_}{default} for @attrs_persisted;
181              
182 0   0     0 defined $opts->{$_} and $item->{$_} = $opts->{$_} for @attrs_persisted;
183              
184 0 0       0 unless( eval { $self->$method_add( $key, $item ); 1 } ) {
  0         0  
  0         0  
185 0         0 my $err = "$@"; chomp $err;
  0         0  
186 0         0 $cinv->responderr( "Cannot add $desc1 '$key' - $err" );
187 0         0 return;
188             }
189              
190 0         0 $cinv->respond( "Added $desc1 '$key'" );
191 0         0 return;
192             }
193 12         46 );
194             }
195              
196 16 100       633 unless( exists $commands{mod} ) {
197 12 50       239 defined $method_get or croak "No get method defined for mod subcommand";
198              
199             $commands{mod} = apply_subattrs_for_pkg( $caller,
200             Command_description => qq("Modify an existing $desc1"),
201             Command_subof => qq('$name'),
202             Command_arg => qq('$keyattr'),
203 48         96 ( map { +Command_opt => $_ } @opts_mod ),
204             sub {
205 0     0   0 my $self = shift;
        0      
206 0         0 my ( $key, $opts, $cinv ) = @_;
207              
208 0         0 my $item = $self->$method_get( $key );
209              
210 0 0       0 unless( $item ) {
211 0         0 $cinv->responderr( "No such $desc1 '$key'" );
212 0         0 return;
213             }
214              
215 0         0 my %mod;
216 0   0     0 exists $opts->{$_} and $mod{$_} = $opts->{$_} for @attrs_persisted;
217 0   0     0 exists $opts->{"no-$_"} and $mod{$_} = $attrs{$_}{default} for @attrs_persisted;
218              
219 0 0       0 if( $method_set ) {
220 0         0 $self->$method_set( $key, \%mod );
221             }
222             else {
223 0         0 $item->{$_} = $mod{$_} for keys %mod;
224             }
225              
226 0         0 $cinv->respond( "Modified $desc1 '$key'" );
227 0         0 return;
228             }
229 12         74 );
230             }
231              
232 16 100       608 unless( exists $commands{del} ) {
233 12 50       28 defined $method_del or croak "No del method defined for del subcommand";
234              
235             $commands{del} = apply_subattrs_for_pkg( $caller,
236             Command_description => qq("Delete a $desc1"),
237             Command_subof => qq('$name'),
238             Command_arg => qq('$keyattr'),
239             sub {
240 0     0   0 my $self = shift;
241 0         0 my ( $key, $cinv ) = @_;
242              
243 0         0 my $item = $self->$method_get( $key );
244              
245 0 0       0 unless( $item ) {
246 0         0 $cinv->responderr( "No such $desc1 '$key'" );
247 0         0 return;
248             }
249              
250 0 0       0 unless( eval { $self->$method_del( $key, $item ); 1 } ) {
  0         0  
  0         0  
251 0         0 my $err = "$@"; chomp $err;
  0         0  
252 0         0 $cinv->responderr( "Cannot delete $desc1 '$key' - $err" );
253 0         0 return;
254             }
255              
256 0         0 $cinv->respond( "Removed $desc1 '$key'" );
257 0         0 return;
258             }
259 12         101 );
260             }
261              
262             # Now delete present-but-undef ones; these are where the caller vetoed the
263             # above autogeneration
264 16   100     678 defined $commands{$_} or delete $commands{$_} for keys %commands;
265              
266 16         26 my %subs;
267 16         95 $subs{"command_${name}_$_"} = $commands{$_} for keys %commands;
268              
269             $subs{"command_${name}"} = apply_subattrs_for_pkg( $caller,
270             Command_description => qq("Display or manipulate $desc2"),
271             # body matters not but it needs to be a cloned closure
272 16     0   37 do { my $dummy; sub { undef $dummy } }
  16         15  
  16         80  
  0         0  
273             );
274              
275             {
276 4     4   27 no strict 'refs';
  4         8  
  4         2206  
  16         930  
277 16         47 *{"${caller}::$_"} = $subs{$_} for keys %subs;
  68         266  
278             }
279              
280 16 100 100     247 if( !defined $config or $config ) {
281 12   100     57 my $config_type = $config->{type} || "array";
282 12         26 my $type_array = $config_type eq "array";
283 12         16 my $type_hash = $config_type eq "hash";
284 12 50 66     46 $type_array or $type_hash or
285             die "Expected config type either 'array' or 'hash'";
286              
287             # Optional config-related methods
288 12         17 my $method_store = $config->{store};
289 12         16 my $method_load = $config->{load};
290              
291             # Configuration load/store
292             install_modifier $caller, after => load_configuration => sub {
293 0     0   0 my $self = shift;
294 0         0 my ( $ynode ) = @_;
295              
296 0 0       0 my $ynodes = $ynode->{$name} or return;
297              
298 0 0       0 foreach my $this ( $type_array ? @$ynodes : keys %$ynodes ) {
299 0         0 my $item = {};
300 0 0       0 my $n = $type_array ? $this : $ynodes->{$this};
301              
302 0         0 $item->{$_} = $n->{$_} for @attrs_persisted;
303 0 0       0 $item->{$keyattr} = $this if $type_hash;
304              
305 0         0 $self->$method_add( $item->{$keyattr}, $item );
306              
307 0 0 0     0 if( ref $method_load or $method_load && $self->can( $method_load ) ) {
      0        
308 0         0 $self->$method_load( $item->{$keyattr}, $n );
309             }
310             }
311 12         109 };
312              
313             install_modifier $caller, after => store_configuration => sub {
314 0     0     my $self = shift;
315 0           my ( $ynode ) = @_;
316              
317 0 0 0       my $ynodes = $ynode->{$name} ||= $type_array ? [] : YAML::Node->new({});
318 0 0         $type_array ? ( @$ynodes = () ) : ( %$ynodes = () );
319              
320 0           foreach my $item ( $self->$method_list ) {
321 0           my $n = YAML::Node->new({});
322              
323 0   0       defined $item->{$_} and $n->{$_} = $item->{$_} for @attrs_persisted;
324              
325 0 0 0       if( ref $method_store or $method_store && $self->can( $method_store ) ) {
      0        
326 0           $self->$method_store( $item->{$keyattr}, $n );
327             }
328              
329             $type_array ?
330             ( push @$ynodes, $n ) :
331 0 0         do { $ynodes->{$n->{$keyattr}} = $n; delete $n->{$keyattr} };
  0            
  0            
332             }
333 12         2190 };
334             }
335             }
336              
337             0x55AA;