File Coverage

blib/lib/Class/Container.pm
Criterion Covered Total %
statement 205 251 81.7
branch 79 136 58.1
condition 30 49 61.2
subroutine 29 31 93.5
pod 12 17 70.6
total 355 484 73.3


line stmt bran cond sub pod time code
1             package Class::Container;
2              
3             $VERSION = '0.12';
4             $VERSION = eval $VERSION if $VERSION =~ /_/;
5              
6             my $HAVE_WEAKEN;
7             BEGIN {
8 2     2   24   eval {
9 2         31     require Scalar::Util;
10 2         47     Scalar::Util->import('weaken');
11 2         21     $HAVE_WEAKEN = 1;
12               };
13               
14 2 50       26   *weaken = sub {} unless defined &weaken;
  0         0  
15             }
16              
17 2     2   30 use strict;
  2         17  
  2         31  
18 2     2   28 use Carp;
  2         73  
  2         34  
19              
20             # The create_contained_objects() method lets one object
21             # (e.g. Compiler) transparently create another (e.g. Lexer) by passing
22             # creator parameters through to the created object.
23             #
24             # Any auto-created objects should be declared in a class's
25             # %CONTAINED_OBJECTS hash. The keys of this hash are objects which
26             # can be created and the values are the default classes to use.
27              
28             # For instance, the key 'lexer' indicates that a 'lexer' parameter
29             # should be silently passed through, and a 'lexer_class' parameter
30             # will trigger the creation of an object whose class is specified by
31             # the value. If no value is present there, the value of 'lexer' in
32             # the %CONTAINED_OBJECTS hash is used. If no value is present there,
33             # no contained object is created.
34             #
35             # We return the list of parameters for the creator. If contained
36             # objects were auto-created, their creation parameters aren't included
37             # in the return value. This lets the creator be totally ignorant of
38             # the creation parameters of any objects it creates.
39              
40 2     2   51 use Params::Validate qw(:all);
  2         20  
  2         44  
41             Params::Validate::validation_options( on_fail => sub { die @_ } );
42              
43             my %VALID_PARAMS = ();
44             my %CONTAINED_OBJECTS = ();
45             my %VALID_CACHE = ();
46             my %CONTAINED_CACHE = ();
47             my %DECORATEES = ();
48              
49             sub new
50             {
51 54     54 1 12118     my $proto = shift;
52 54   33     733     my $class = ref($proto) || $proto;
53 54         999     my $self = bless scalar validate_with
54                   (
55                    params => $class->create_contained_objects(@_),
56                    spec => $class->validation_spec,
57                    called => "$class->new()",
58                   ), $class;
59 51 50       4523     if ($HAVE_WEAKEN) {
60 51         546       my $c = $self->get_contained_object_spec;
61 51         592       foreach my $name (keys %$c) {
62 40 100       525 next if $c->{$name}{delayed};
63 21         211 $self->{$name}{container}{container} = $self;
64 21         286 weaken $self->{$name}{container}{container};
65                   }
66                 }
67 51         705     return $self;
68             }
69              
70             sub all_specs
71             {
72 0     0 0 0     require B::Deparse;
73 0         0     my %out;
74              
75 0         0     foreach my $class (sort keys %VALID_PARAMS)
76                 {
77 0         0 my $params = $VALID_PARAMS{$class};
78              
79 0         0 foreach my $name (sort keys %$params)
80             {
81 0         0 my $spec = $params->{$name};
82 0         0 my ($type, $default);
83 0 0       0 if ($spec->{isa}) {
84 0         0 my $obj_class;
85              
86 0         0 $type = 'object';
87              
88 0 0       0 if (exists $CONTAINED_OBJECTS{$class}{$name}) {
89 0         0 $default = "$CONTAINED_OBJECTS{$class}{$name}{class}->new";
90             }
91             } else {
92 0         0 ($type, $default) = ($spec->{parse}, $spec->{default});
93             }
94              
95 0 0       0 if (ref($default) eq 'CODE') {
    0          
    0          
96 0         0 $default = 'sub ' . B::Deparse->new()->coderef2text($default);
97 0         0 $default =~ s/\s+/ /g;
98             } elsif (ref($default) eq 'ARRAY') {
99 0         0 $default = '[' . join(', ', map "'$_'", @$default) . ']';
100             } elsif (ref($default) eq 'Regexp') {
101 0         0 $type = 'regex';
102 0         0 $default =~ s,^\(\?(\w*)-\w*:(.*)\),/$2/$1,;
103 0         0 $default = "qr$default";
104             }
105 0 0       0 unless ($type) {
106             # Guess from the validation spec
107 0 0       0 $type = ($spec->{type} & ARRAYREF ? 'list' :
    0          
    0          
    0          
108             $spec->{type} & SCALAR ? 'string' :
109             $spec->{type} & CODEREF ? 'code' :
110             $spec->{type} & HASHREF ? 'hash' :
111             undef);  # Oh well
112             }
113              
114 0   0     0 my $descr = $spec->{descr} || '(No description available)';
115 0 0 0     0 $out{$class}{valid_params}{$name} = { type => $type,
    0          
116             pv_type => $spec->{type},
117             default => $default,
118             descr => $descr,
119             required => defined $default || $spec->{optional} ? 0 : 1,
120             public => exists $spec->{public} ? $spec->{public} : 1,
121             };
122             }
123              
124 0         0 $out{$class}{contained_objects} = {};
125 0 0       0 next unless exists $CONTAINED_OBJECTS{$class};
126 0         0 my $contains = $CONTAINED_OBJECTS{$class};
127              
128 0         0 foreach my $name (sort keys %$contains)
129             {
130 0         0 $out{$class}{contained_objects}{$name} 
131 0         0 = {map {$_, $contains->{$name}{$_}} qw(class delayed descr)};
132             }
133                 }
134              
135 0         0     return %out;
136             }
137              
138             sub dump_parameters {
139 12     12 1 106   my $self = shift;
140 12   66     127   my $class = ref($self) || $self;
141               
142 12         99   my %params;
143 12         95   foreach my $param (keys %{ $class->validation_spec }) {
  12         198  
144 30 100       301     next if $param eq 'container';
145 18         199     my $spec = $class->validation_spec->{$param};
146 18 100 66     288     if (ref($self) and defined $self->{$param}) {
147 16         169       $params{$param} = $self->{$param};
148                 } else {
149 2 50       26       $params{$param} = $spec->{default} if exists $spec->{default};
150                 }
151               }
152               
153 12         130   foreach my $name (keys %{ $class->get_contained_object_spec }) {
  12         118  
154 6 50       63     next unless ref($self);
155 6 100       82     my $contained = ($self->{container}{contained}{$name}{delayed} ?
156             $self->delayed_object_class($name) :
157             $params{$name});
158                 
159 6 50       100     my $subparams = UNIVERSAL::isa($contained, __PACKAGE__) ? $contained->dump_parameters : {};
160                 
161 6   100     83     my $more = $self->{container}{contained}{$name}{args} || {};
162 6         48     $subparams->{$_} = $more->{$_} foreach keys %$more;
  6         64  
163                 
164 6         109     @params{ keys %$subparams } = values %$subparams;
165 6         77     delete $params{$name};
166               }
167 12         176   return \%params;
168             }
169              
170             sub show_containers {
171 23     23 1 293   my $self = shift;
172 23         198   my $name = shift;
173 23         280   my %args = (indent => '', @_);
174              
175 23 100       238   $name = defined($name) ? "$name -> " : "";
176              
177 23         236   my $out = "$args{indent}$name$self";
178 23 100       286   $out .= " (delayed)" if $args{delayed};
179 23         219   $out .= "\n";
180 23 50       338   return $out unless $self->isa(__PACKAGE__);
181              
182 23 100       244   my $specs = ref($self) ? $self->{container}{contained} : $self->get_contained_object_spec;
183              
184 23         274   while (my ($name, $spec) = each %$specs) {
185 18   66     253     my $class = $args{args}{"${name}_class"} || $spec->{class};
186 18         174     $self->_load_module($class);
187              
188 18 50       245     if ($class->isa(__PACKAGE__)) {
189 18         320       $out .= $class->show_containers($name,
190             indent => "$args{indent} ",
191             args => $spec->{args},
192             delayed => $spec->{delayed});
193                 } else {
194 0         0       $out .= "$args{indent} $name -> $class\n";
195                 }
196               }
197              
198 23         5045   return $out;
199             }
200              
201             sub _expire_caches {
202 58     58   963   %VALID_CACHE = %CONTAINED_CACHE = ();
203             }
204              
205             sub valid_params {
206 38     38 1 3695   my $class = shift;
207 38 100       429   if (@_) {
208 33         497     $class->_expire_caches;
209 33 100 66     459     $VALID_PARAMS{$class} = @_ == 1 && !defined($_[0]) ? {} : {@_};
210               }
211 38   100     467   return $VALID_PARAMS{$class} ||= {};
212             }
213              
214             sub contained_objects
215             {
216 24     24 1 487     my $class = shift;
217 24         314     $class->_expire_caches;
218 24         360     $CONTAINED_OBJECTS{$class} = {};
219 24         288     while (@_) {
220 24         230       my ($name, $spec) = (shift, shift);
221 24 100       355       $CONTAINED_OBJECTS{$class}{$name} = ref($spec) ? $spec : { class => $spec };
222                 }
223             }
224              
225             sub _decorator_AUTOLOAD {
226 9     9   128   my $self = shift;
227 2     2   136   no strict 'vars';
  2         23  
  2         48  
228 9         251   my ($method) = $AUTOLOAD =~ /([^:]+)$/;
229 9 100       102   return if $method eq 'DESTROY';
230 1 50       14   die qq{Can't locate object method "$method" via package $self} unless ref($self);
231 1 50       15   my $subr = $self->{_decorates}->can($method)
232                 or die qq{Can't locate object method "$method" via package } . ref($self);
233 1         12   unshift @_, $self->{_decorates};
234 1         14   goto $subr;
235             }
236              
237             sub _decorator_CAN {
238 11     11   2651   my ($self, $method) = @_;
239 11 100       319   return $self->SUPER::can($method) if $self->SUPER::can($method);
240 2 50       24   if (ref $self) {
241 2 100       28     return $self->{_decorates}->can($method) if $self->{_decorates};
242 1         14     return undef;
243               } else {
244 0         0     return $DECORATEES{$self}->can($method);
245               }
246             }
247              
248             sub decorates {
249 5     5 1 104   my ($class, $super) = @_;
250               
251 2     2   32   no strict 'refs';
  2         19  
  2         24  
252 5   33     49   $super ||= ${$class . '::ISA'}[0];
  5         55  
253               
254             # Pass through unknown method invocations
255 5         44   *{$class . '::AUTOLOAD'} = \&_decorator_AUTOLOAD;
  5         59  
256 5         46   *{$class . '::can'} = \&_decorator_CAN;
  5         55  
257               
258 5         46   $DECORATEES{$class} = $super;
259 5         67   $VALID_PARAMS{$class}{_decorates} = { isa => $super, optional => 1 };
260             }
261              
262             sub container {
263 1     1 1 30   my $self = shift;
264 1 50       11   die "The ", ref($self), "->container() method requires installation of Scalar::Util" unless $HAVE_WEAKEN;
265 1         16   return $self->{container}{container};
266             }
267              
268             sub call_method {
269 5     5 0 60   my ($self, $name, $method, @args) = @_;
270               
271 5 50       56   my $class = $self->contained_class($name)
272                 or die "Unknown contained item '$name'";
273              
274 5         57   $self->_load_module($class);
275 5         44   return $class->$method( %{ $self->{container}{contained}{$name}{args} }, @args );
  5         76  
276             }
277              
278             # Accepts a list of key-value pairs as parameters, representing all
279             # parameters taken by this object and its descendants. Returns a list
280             # of key-value pairs representing *only* this object's parameters.
281             sub create_contained_objects
282             {
283             # Typically $self doesn't exist yet, $_[0] is a string classname
284 54     54 0 509     my $class = shift;
285              
286 54         640     my $c = $class->get_contained_object_spec;
287 54 100 100     1034     return {@_, container => {}} unless %$c or $DECORATEES{$class};
288                 
289 35         712     my %args = @_;
290                 
291 35 100       510     if ($DECORATEES{$class}) {
292             # Fix format
293 8 100 66     106       $args{decorate_class} = [$args{decorate_class}]
294             if $args{decorate_class} and !ref($args{decorate_class});
295                   
296             # Figure out which class to decorate
297 8         67       my $decorate;
298 8 100       79       if (my $c = $args{decorate_class}) {
299 3 50       32 $decorate = @$c