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 <don@donarmstrong.com>.
7 package Class::Modular;
11 Class::Modular -- Modular class generation superclass
17 use base qw(Class::Modular);
20 BEGIN{@METHODS=qw(blah)};
31 sub method_that_bar_provides{
32 print qq(Hello World!\n);
36 return qw(method_that_bar_provides);
45 $foo->blah && $foo->method_that_bar_provides;
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.
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.
59 This module attempts to fill the middle ground between
60 L<Class::Mutator> and true classless OOP, like L<Class::Classless>.
67 use vars qw($VERSION $DEBUG $REVISION $USE_SAFE);
71 use Storable qw(dclone); # Used for deep copying objects
72 use Safe; # Use Safe when we are dealing with coderefs
76 ($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;
77 $DEBUG = 0 unless defined $DEBUG;
78 $USE_SAFE = 1 unless defined $USE_SAFE;
81 # This is the class_modular namespace, so we don't muck up the
82 # subclass(es) by accident.
84 my $cm = q(__class_modular);
91 $cm->load('Subclass');
93 $cm->load('Subclass',$options);
95 Loads the named Subclass into this object if the named Subclass has
98 If debugging is enabled, will warn about loading already loaded
99 subclasses. Use C<$cm->is_loaded('Subclass')> to avoid these warnings.
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<Class::Modular>
106 object and the options SCALAR are passed to the _methods function.
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.
112 =head3 _init and required submodules
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<Class::Modular> object and the options SCALAR are passed
117 to the _methods function. Typical uses for this call are to load other
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:
124 for my $module (@{"${subclass}::SUB_MODULES"}) {
125 $self->is_loaded($module) || $self->load($module);
131 my ($self,$subclass,$options) = @_;
135 # check to see if the subclass has already been loaded.
137 if (not defined $self->{$cm}{_subclasses}{$subclass}){
140 # Yeah, I don't care if calling an inherited AUTOLOAD
141 # for a non method is deprecated. Bite me.
142 no warnings 'deprecated';
143 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 my $methods = can($subclass,"_methods");
147 if (defined $methods) {
148 $self->_addmethods($subclass,&$methods($self,$options));
151 $self->_addmethods($subclass,@{"${subclass}::METHODS"})
153 my $init = can($subclass,"_init");
155 &$init($self,$options);
158 for my $module (@{"${subclass}::SUB_MODULES"}) {
159 $self->is_loaded($module) || $self->load($module);
164 $self->{$cm}{_subclasses}{$subclass} ||= {};
167 carp "Not reloading subclass $subclass" if $DEBUG;
173 if ($cm->is_loaded('Subclass')) {
177 Tests to see if the named subclass is loaded.
179 Returns 1 if the subclass has been loaded, 0 otherwise.
184 my ($self,$subclass) = @_;
186 # An entry will exist in the _subclasses hashref only if
187 return 1 if exists $self->{$cm}{_subclasses}{$subclass}
188 and defined $self->{$cm}{_subclasses}{$subclass};
194 $obj->override('methodname', $code_ref)
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.
201 Methods overridden here are _NOT_ overrideable in _addmethods. This
202 may need to be changed.
207 my ($self, $method_name, $function_reference) = @_;
209 $self->{$cm}{_methodhash}{$method_name}{reference} = $function_reference;
210 $self->{$cm}{_methodhash}{$method_name}{overridden} = 1;
216 my $clone = $obj->clone
218 Produces a clone of the object with duplicates of all data and/or new
219 connections as appropriate.
221 Calls _clone on all loaded subclasses.
223 Warns if debugging is on for classes which don't have a _clone method.
224 Dies on other errors.
226 clone uses L<Safe> to allow L<Storable> 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.]
236 bless $clone, ref($self);
238 # copy data structures at this level
239 if ($self->{$cm}{use_safe}) {
241 $safe->permit(qw(:default require));
242 local $Storable::Deparse = 1;
243 local $Storable::Eval = sub { $safe->reval($_[0]) };
244 $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
245 $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
248 $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
249 $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
252 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
253 # Find out if the subclass has a clone method.
254 # If it does, call it, die on errors.
255 my $function = UNIVERSAL::can($subclass, '_clone');
258 # No, I could care less that AUTOLOAD is
259 # deprecated. Eat me.
260 no warnings 'deprecated';
261 &{"${subclass}::_clone"}($self,$clone);
264 # Die unless we've hit an undefined subroutine.
265 if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){
266 die "Failed while trying to clone: $@";
269 carp "No _clone method defined for $subclass" if $DEBUG;
279 Class::Modular->can('METHOD');
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
285 Returns a coderef to the method if the method is supported, undef
291 my ($self,$method,$vars) = @_;
293 croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method;
295 if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) {
296 # If the method is defined, return a reference to the
298 return $self->{$cm}{_methodhash}{$method}{reference};
301 # Otherwise, let UNIVERSAL::can deal with the method
303 return UNIVERSAL::can($self,$method);
310 Class::Modular->isa('TYPE');
312 Replaces UNIVERSAL's isa method with one that knows which modules have
313 been loaded into this object. Calls C<is_loaded> with the type passed,
314 then calls UNIVERSAL::isa if the type isn't loaded.
319 my ($self,$type) = @_;
321 croak "Usage: isa(object-ref, type);\n" if not defined $type;
323 return $self->is_loaded($type) || UNIVERSAL::isa($self,$type);
330 $obj->handledby('methodname');
331 $obj->handledby('Class::Method::methodname');
333 Returns the subclass that handles the method methodname.
338 my ($self,$method_name) = @_;
340 $method_name =~ s/.*\://;
342 if (exists $self->{$cm}{_methodhash}{$method_name}) {
343 return $self->{$cm}{_methodhash}{$method_name}{subclass};
351 $obj = Foo::Bar->new(qw(baz quux));
353 Creates a new Foo::Bar object
355 Aditional arguments can be passed to this creator, and they are stored
356 in $self->{creation_args} (and $self->{$cm}{creation_args} by
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.
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.
370 my ($class,@args) = @_;
372 # We shouldn't be called $me->new, but just in case
373 $class = ref($class) || $class;
377 # But why, Don, are you being evil and not using the two argument
380 # My child, we always want to go to Class::Modular first,
381 # otherwise we will be unable to override methods in subclasses.
383 # But doesn't this mean that subclasses won't be able to override
386 # Only if they don't also override new!
388 bless $self, 'Class::Modular';
392 # Now we call our subclass's load routine so that our evil deeds
401 =head1 FUNCTIONS YOU PROBABLY DON'T CARE ABOUT
407 Calls all subclass _destroy methods.
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.
417 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
418 # use eval to try and call the subclasses _destroy method.
419 # Ignore no such function errors, but trap other types of
423 # Shove off, deprecated AUTOLOAD warning!
424 no warnings 'deprecated';
425 &{"${subclass}::_destroy"}($self);
428 if ($@ !~ /^Undefined (function|subroutine) \&?${subclass}::_destroy (|called )at [^\n]*$/){
429 die "Failed while trying to destroy: $@";
432 carp "No _destroy method defined for $subclass" if $DEBUG;
441 The AUTOLOAD function is responsible for calling child methods which
442 have been installed into the current Class::Modular handle.
444 Subclasses that have a new function as well as an AUTOLOAD function
445 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
447 $Class::Modular::AUTOLOAD = $AUTOLOAD;
448 goto &Class::Modular::AUTOLOAD;
450 Failure to do the above will break Class::Modular utterly.
455 my $method = $AUTOLOAD;
461 if (not ref($self)) {
462 carp "Not a reference in AUTOLOAD.";
466 if (exists $self->{$cm}{_methodhash}{$method} and
467 defined $self->{$cm}{_methodhash}{$method}{reference}) {
469 my $method = \&{$self->{$cm}{_methodhash}{$method}{reference}};
474 croak "Undefined function $AUTOLOAD";
482 Stores the arguments used at new so modules that are loaded later can
483 read them from B<creation_args>
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.
491 my ($self,@creation_args) = @_;
493 my $creation_args = [@_];
494 $self->{creation_args} = $creation_args if not exists $self->{creation_args};
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 $self->{$cm}->{creation_args} = $creation_args;
499 $self->{$cm}->{use_safe} = $USE_SAFE;
507 Given an array of methods, adds the methods into the _methodhash
510 Methods that have previously been overridden by override are _NOT_
511 overridden again. This may need to be adjusted in load.
515 sub _addmethods($@) {
516 my ($self,$subclass,@methods) = @_;
518 # stick the method into the table
519 # DLA: Make with the munchies!
521 foreach my $method (@methods) {
522 if (not $method =~ /^$subclass/) {
523 $method = $subclass.'::'.$method;
525 my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
526 if (exists $self->{$cm}{_methodhash}{$method_name}) {
527 if ($self->{$cm}{_methodhash}{$method_name}{overridden}) {
528 carp "Not overriding already overriden method $method_name\n" if $DEBUG;
531 carp "Overriding $method_name $self->{$cm}{_methodhash}{$method_name}{reference} with $method\n";
533 $self->{$cm}{_methodhash}{$method_name}{reference} = $method;
534 $self->{$cm}{_methodhash}{$method_name}{subclass} = $subclass;
547 Because this module works through AUTOLOAD, utilities that use
548 can($object) instead of $object->can() will fail to see routines that
549 are actually there. Params::Validate, an excellent module, is
550 currently one of these offenders.
554 This module is part of DA, Don Armstrong's Modules, and is released
555 under the terms of the GPL version 2, or any later version. See the
556 file README and COPYING for more information.
558 Copyright 2003, 2005 by Don Armstrong <don@donarmstrong.com>