File Coverage

blib/lib/Class/Modular.pm
Criterion Covered Total %
statement 106 147 72.1
branch 18 56 32.1
condition 7 19 36.8
subroutine 24 26 92.3
pod 8 8 100.0
total 163 256 63.6


line stmt bran cond sub pod time code
1             # This module is part of DA, Don Armstrong's Modules, and is released
2             # under the terms of the GPL version 2, or any later version. See the
3             # file README and COPYING for more information.
4             # Copyright 2003,2005 by Don Armstrong .
5             # $Id: Modular.pm 45 2006-11-17 22:30:15Z don $
6              
7             package Class::Modular;
8              
9             =head1 NAME
10              
11             Class::Modular -- Modular class generation superclass
12              
13             =head1 SYNOPSIS
14              
15             package Foo;
16              
17             use base qw(Class::Modular);
18              
19             use vars (@METHODS);
20             BEGIN{@METHODS=qw(blah)};
21              
22             sub blah{
23             my $self = shift;
24             return 1;
25             }
26              
27             [...]
28              
29             package Bar;
30              
31             sub method_that_bar_provides{
32             print qq(Hello World!\n);
33             }
34              
35             sub _methods($$){
36             return qw(method_that_bar_provides);
37             }
38              
39             [...]
40              
41             use Foo;
42              
43             $foo = new Foo;
44             $foo->load('Bar');
45             $foo->blah && $foo->method_that_bar_provides;
46              
47              
48             =head1 DESCRIPTION
49              
50             Class::Modular is a superclass for generating modular classes, where
51             methods can be added into the class from the perspective of the
52             object, rather than the perspective of the class.
53              
54             That is, you can create a class which has a set of generic common
55             functions. Less generic functions can be included or overridden
56             without modifying the base classes. This allows for code to be more
57             modular, and reduces code duplication.
58              
59             This module attempts to fill the middle ground between
60             L and true classless OOP, like L.
61              
62             =head1 FUNCTIONS
63              
64             =cut
65              
66 1     1   52766 use strict;
  1         3  
  1         54  
67 1     1   6 use vars qw($VERSION $DEBUG $REVISION $USE_SAFE);
  1         17  
  1         91  
68              
69 1     1   7 use Carp;
  1         7  
  1         112  
70              
71 1     1   40976 use Storable qw(dclone); # Used for deep copying objects
  1         9055  
  1         109  
72 1     1   2705 use Safe; # Use Safe when we are dealing with coderefs
  1         65725  
  1         23  
73              
74             BEGIN{
75 1     1   183 $VERSION = q$0.05$;
76 1         3 ($REVISION) = q$LastChangedRevision: 45 $ =~ /\$LastChangedRevision:\s+([^\s+])/;
77 1 50       6 $DEBUG = 0 unless defined $DEBUG;
78 1 50       114 $USE_SAFE = 1 unless defined $USE_SAFE;
79             }
80              
81             # This is the class_modular namespace, so we don't muck up the
82             # subclass(es) by accident.
83              
84             my $cm = q(__class_modular);
85              
86             our $AUTOLOAD;
87              
88              
89             =head2 load
90              
91             $cm->load('Subclass');
92             # or
93             $cm->load('Subclass',$options);
94              
95             Loads the named Subclass into this object if the named Subclass has
96             not been loaded.
97              
98             If debugging is enabled, will warn about loading already loaded
99             subclasses. Use C<$cm->is_loaded('Subclass')> to avoid these warnings.
100              
101             =head3 Methods
102              
103             If the subclass has a C<_methods> function (or at least,
104             UNIVERSAL::can thinks it does), C<_methods> is called to return a LIST
105             of methods that the subclass wishes to handle. The L
106             object and the options SCALAR are passed to the _methods function.
107              
108             If the subclass does not have a C<_methods> function, then the array
109             C<@{"${subclass}::METHODS"}> is used to determine the methods that the
110             subclass will handle.
111              
112             =head3 _init and required submodules
113              
114             If the subclass has a C<_init> function (or at least, UNIVERSAL::can
115             thinks it does), C<_init> is called right after the module is
116             loaded. The L object and the options SCALAR are passed
117             to the _methods function. Typical uses for this call are to load other
118             required submodules.
119              
120             As this is the most common thing to do in C<_init>, if a subclass
121             doesn't have one, then the array C<@{"${subclass}::SUB_MODULES"}> is
122             used to determine the subclass that need to be loaded:
123              
124             for my $module (@{"${subclass}::SUB_MODULES"}) {
125             $self->is_loaded($module) || $self->load($module);
126             }
127              
128             =cut
129              
130             sub load($$;$) {
131 1     1 1 3 my ($self,$subclass,$options) = @_;
132              
133 1   50     7 $options ||= {};
134              
135             # check to see if the subclass has already been loaded.
136              
137 1 50       39 if (not defined $self->{$cm}{_subclasses}{$subclass}){
138 1         3 eval {
139 1     1   13 no strict 'refs';
  1         2  
  1         43  
140             # Yeah, I don't care if calling an inherited AUTOLOAD
141             # for a non method is deprecated. Bite me.
142 1     1   8 no warnings 'deprecated';
  1         3  
  1         602  
143 1 50       69 eval "require $subclass" or die $@;
144             # We should read @METHODS and @SUB_MODULES and just do
145             # the right thing if at all possible.
146 1         7 my $methods = can($subclass,"_methods");
147 1 50       4 if (defined $methods) {
148 0         0 $self->_addmethods($subclass,&$methods($self,$options));
149             }
150             else {
151 1         1 $self->_addmethods($subclass,@{"${subclass}::METHODS"})
  1         37  
152             }
153 1         5 my $init = can($subclass,"_init");
154 1 50       4 if (defined $init) {
155 1         3 &$init($self,$options);
156             }
157             else {
158 0         0 for my $module (@{"${subclass}::SUB_MODULES"}) {
  0         0  
159 0 0       0 $self->is_loaded($module) || $self->load($module);
160             }
161             }
162             };
163 1 50       4 die $@ if $@;
164 1   50     7 $self->{$cm}{_subclasses}{$subclass} ||= {};
165             }
166             else {
167 0 0       0 carp "Not reloading subclass $subclass" if $DEBUG;
168             }
169             }
170              
171             =head2 is_loaded
172              
173             if ($cm->is_loaded('Subclass')) {
174             # do something
175             }
176              
177             Tests to see if the named subclass is loaded.
178              
179             Returns 1 if the subclass has been loaded, 0 otherwise.
180              
181             =cut
182              
183             sub is_loaded($$){
184 1     1 1 276 my ($self,$subclass) = @_;
185              
186             # An entry will exist in the _subclasses hashref only if
187 1 50 33     12 return 1 if exists $self->{$cm}{_subclasses}{$subclass}
188             and defined $self->{$cm}{_subclasses}{$subclass};
189 0         0 return 0;
190             }
191              
192             =head2 override
193              
194             $obj->override('methodname', $code_ref)
195              
196             Allows you to override utility functions that are called internally to
197             provide a different default function. It's superficially similar to
198             _addmethods, which is called by load, but it deals with code
199             references, and requires the method name to be known.
200              
201             Methods overridden here are _NOT_ overrideable in _addmethods. This
202             may need to be changed.
203              
204             =cut
205              
206             sub override {
207 1     1 1 224 my ($self, $method_name, $function_reference) = @_;
208              
209 1         3 $self->{$cm}{_methodhash}{$method_name}{reference} = $function_reference;
210 1         5 $self->{$cm}{_methodhash}{$method_name}{overridden} = 1;
211             }
212              
213              
214             =head2 clone
215              
216             my $clone = $obj->clone
217              
218             Produces a clone of the object with duplicates of all data and/or new
219             connections as appropriate.
220              
221             Calls _clone on all loaded subclasses.
222              
223             Warns if debugging is on for classes which don't have a _clone method.
224             Dies on other errors.
225              
226             clone uses L to allow L to deparse code references
227             sanely. Set C<$Class::Modular::USE_SAFE = 0> to disable this. [Doing
228             this may cause errors from Storable about CODE references.]
229              
230             =cut
231              
232             sub clone {
233 1     1 1 3 my ($self) = @_;
234              
235 1         2 my $clone = {};
236 1         3 bless $clone, ref($self);
237              
238             # copy data structures at this level
239 1 50       5 if ($self->{$cm}{use_safe}) {
240 1         9 my $safe = new Safe;
241 1         1390 $safe->permit(qw(:default require));
242 1         11 local $Storable::Deparse = 1;
243 1     1   6 local $Storable::Eval = sub { $safe->reval($_[0]) };
  1         9  
244 1     1   11 $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
  1         41  
  1         982  
  1         344  
245 0         0 $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
246             }
247             else {
248 0         0 $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
249 0         0 $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
250             }
251              
252 0         0 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
  0         0  
253             # Find out if the subclass has a clone method.
254             # If it does, call it, die on errors.
255 0         0 my $function = UNIVERSAL::can($subclass, '_clone');
256 0         0 eval {
257 1     1   8 no strict 'refs';
  1         1  
  1         31  
258             # No, I could care less that AUTOLOAD is
259             # deprecated. Eat me.
260 1     1   5 no warnings 'deprecated';
  1         2  
  1         506  
261 0         0 &{"${subclass}::_clone"}($self,$clone);
  0         0  
262             };
263 0 0       0 if ($@) {
264             # Die unless we've hit an undefined subroutine.
265 0 0       0 if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){
266 0         0 die "Failed while trying to clone: $@";
267             }
268             else {
269 0 0       0 carp "No _clone method defined for $subclass" if $DEBUG;
270             }
271             }
272             }
273             }
274              
275              
276             =head2 can
277              
278             $obj->can('METHOD');
279             Class::Modular->can('METHOD');
280              
281             Replaces UNIVERSAL's can method so that handled methods are reported
282             correctly. Calls UNIVERSAL::can in the places where we don't know
283             anything it doesn't.
284              
285             Returns a coderef to the method if the method is supported, undef
286             otherwise.
287              
288             =cut
289              
290             sub can{
291 3     3 1 218 my ($self,$method,$vars) = @_;
292              
293 3 50       10 croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method;
294              
295 3 100 66     16 if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) {
296             # If the method is defined, return a reference to the
297             # method.
298 1         8 return $self->{$cm}{_methodhash}{$method}{reference};
299             }
300             else {
301             # Otherwise, let UNIVERSAL::can deal with the method
302             # appropriately.
303 2         17 return UNIVERSAL::can($self,$method);
304             }
305             }
306              
307             =head2 isa
308              
309             $obj->isa('TYPE');
310             Class::Modular->isa('TYPE');
311              
312             Replaces UNIVERSAL's isa method with one that knows which modules have
313             been loaded into this object. Calls C with the type passed,
314             then calls UNIVERSAL::isa if the type isn't loaded.
315              
316             =cut
317              
318             sub isa{
319 0     0 1 0 my ($self,$type) = @_;
320              
321 0 0       0 croak "Usage: isa(object-ref, type);\n" if not defined $type;
322              
323 0   0     0 return $self->is_loaded($type) || UNIVERSAL::isa($self,$type);
324             }
325              
326              
327              
328             =head2 handledby
329              
330             $obj->handledby('methodname');
331             $obj->handledby('Class::Method::methodname');
332              
333             Returns the subclass that handles the method methodname.
334              
335             =cut
336              
337             sub handledby{
338 0     0 1 0 my ($self,$method_name) = @_;
339              
340 0         0 $method_name =~ s/.*\://;
341              
342 0 0       0 if (exists $self->{$cm}{_methodhash}{$method_name}) {
343 0         0 return $self->{$cm}{_methodhash}{$method_name}{subclass};
344             }
345 0         0 return undef;
346             }
347              
348              
349             =head2 new
350              
351             $obj = Foo::Bar->new(qw(baz quux));
352              
353             Creates a new Foo::Bar object
354              
355             Aditional arguments can be passed to this creator, and they are stored
356             in $self->{creation_args} (and $self->{$cm}{creation_args} by
357             _init.
358              
359             This new function creates an object of Class::Modular, and calls the
360             C<$self->load(Foo::Bar)>, which will typically do what you want.
361              
362             If you override this method in your subclasses, you will not be able
363             to use override to override methods defined within those
364             subclasses. This may or may not be a feature. You must also call
365             C<$self->SUPER::_init(@_)> if you override new.
366              
367             =cut
368              
369             sub new {
370 1     1 1 625 my ($class,@args) = @_;
371              
372             # We shouldn't be called $me->new, but just in case
373 1   33     9 $class = ref($class) || $class;
374              
375 1         2 my $self = {};
376              
377             # But why, Don, are you being evil and not using the two argument
378             # bless properly?
379              
380             # My child, we always want to go to Class::Modular first,
381             # otherwise we will be unable to override methods in subclasses.
382              
383             # But doesn't this mean that subclasses won't be able to override
384             # us?
385              
386             # Only if they don't also override new!
387              
388 1         3 bless $self, 'Class::Modular';
389              
390 1         5 $self->_init(@args);
391              
392             # Now we call our subclass's load routine so that our evil deeds
393             # are masked
394              
395 1         6 $self->load($class);
396              
397 1         10 return $self;
398             }
399              
400              
401             =head1 FUNCTIONS YOU PROBABLY DON'T CARE ABOUT
402              
403             =head2 DESTROY
404              
405             undef $foo;
406              
407             Calls all subclass _destroy methods.
408              
409             Subclasses need only implement a _destroy method if they have
410             references that need to be uncircularized, or things that should be
411             disconnected or closed.
412              
413             =cut
414              
415             sub DESTROY{
416 1     1   785 my $self = shift;
417 1         3 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
  1         125  
418             # use eval to try and call the subclasses _destroy method.
419             # Ignore no such function errors, but trap other types of
420             # errors.
421 0         0 eval {
422 1     1   7 no strict 'refs';
  1         2  
  1         31  
423             # Shove off, deprecated AUTOLOAD warning!
424 1     1   6 no warnings 'deprecated';
  1         1  
  1         2993  
425 0         0 &{"${subclass}::_destroy"}($self);
  0         0  
426             };
427 0 0       0 if ($@) {
428 0 0       0 if ($@ !~ /^Undefined (function|subroutine) \&?${subclass}::_destroy (|called )at [^\n]*$/){
429 0         0 die "Failed while trying to destroy: $@";
430             }
431             else {
432 0 0       0 carp "No _destroy method defined for $subclass" if $DEBUG;
433             }
434             }
435             }
436             }
437              
438              
439             =head2 AUTOLOAD
440              
441             The AUTOLOAD function is responsible for calling child methods which
442             have been installed into the current Class::Modular handle.
443              
444             Subclasses that have a new function as well as an AUTOLOAD function
445             must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
446              
447             $Class::Modular::AUTOLOAD = $AUTOLOAD;
448             goto &Class::Modular::AUTOLOAD;
449              
450             Failure to do the above will break Class::Modular utterly.
451              
452             =cut
453              
454             sub AUTOLOAD{
455 2     2   7 my $method = $AUTOLOAD;
456              
457 2         8 $method =~ s/.*\://;
458              
459 2         4 my ($self) = @_;
460              
461 2 50       7 if (not ref($self)) {
462 0         0 carp "Not a reference in AUTOLOAD.";
463 0         0 return;
464             }
465              
466 2 50 33     16 if (exists $self->{$cm}{_methodhash}{$method} and
467             defined $self->{$cm}{_methodhash}{$method}{reference}) {
468             {
469 2         2 my $method = \&{$self->{$cm}{_methodhash}{$method}{reference}};
  2         3  
  2         7  
470 2         8 goto &$method;
471             }
472             }
473             else {
474 0         0 croak "Undefined function $AUTOLOAD";
475             }
476             }
477              
478             =head2 _init
479              
480             $self->_init(@args);
481              
482             Stores the arguments used at new so modules that are loaded later can
483             read them from B
484              
485             You can also override this method, but if you do so, you should call
486             Class::Modular::_init($self,@_) if you don't set creation_args.
487              
488             =cut
489              
490             sub _init {
491 2     2   5 my ($self,@creation_args) = @_;
492              
493 2         4 my $creation_args = [@_];
494 2 100       12 $self->{creation_args} = $creation_args if not exists $self->{creation_args};
495              
496             # Make another reference to this, so we can get it if a subclass
497             # overwrites it, or if it was already set for some reason
498 2         67 $self->{$cm}->{creation_args} = $creation_args;
499 2         7 $self->{$cm}->{use_safe} = $USE_SAFE;
500             }
501              
502              
503             =head2 _addmethods
504              
505             $self->_addmethods()
506              
507             Given an array of methods, adds the methods into the _methodhash
508             calling table.
509              
510             Methods that have previously been overridden by override are _NOT_
511             overridden again. This may need to be adjusted in load.
512              
513             =cut
514              
515             sub _addmethods($@) {
516 1     1   4 my ($self,$subclass,@methods) = @_;
517              
518             # stick the method into the table
519             # DLA: Make with the munchies!
520              
521 1         3 foreach my $method (@methods) {
522 1 50       23 if (not $method =~ /^$subclass/) {
523 1         3 $method = $subclass.'::'.$method;
524             }
525 1         9 my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
526 1 50       41 if (exists $self->{$cm}{_methodhash}{$method_name}) {
527 0 0       0 if ($self->{$cm}{_methodhash}{$method_name}{overridden}) {
528 0 0       0 carp "Not overriding already overriden method $method_name\n" if $DEBUG;
529 0         0 next;
530             }
531 0         0 carp "Overriding $method_name $self->{$cm}{_methodhash}{$method_name}{reference} with $method\n";
532             }
533 1         6 $self->{$cm}{_methodhash}{$method_name}{reference} = $method;
534 1         5 $self->{$cm}{_methodhash}{$method_name}{subclass} = $subclass;
535             }
536              
537             }
538              
539              
540             1;
541              
542              
543             __END__