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,2004 by Don Armstrong <don@donarmstrong.com>.
7 package Class::Modular;
11 Class::Modular -- Modular class generation superclass
17 use base qw(Class::Modular);
21 my $self = bless {}, ref($class) || $class;
22 $self->SUPER::_init(@_);
30 sub method_that_bar_provides{
31 print qq(Hello World!\n);
35 return qw(method_that_bar_provides);
44 $foo->method_that_bar_provides;
49 Class::Modular is a superclass for generating modular classes, where
50 methods can be added into the class from the perspective of the
51 object, rather than the perspective of the class.
53 That is, you can create a class which has a set of generic common
54 functions. Less generic functions can be included or overridden
55 without modifying the base classes. This allows for code to be more
56 modular, and reduces code duplication.
58 This module attempts to fill the middle ground between
59 L<Class::Mutator> and true classless OOP, like L<Class::Classless>.
66 use vars qw($VERSION $DEBUG $REVISION);
70 use Storable qw(dclone); # Used for deep copying objects
73 $VERSION = q$0.01SVN$;
74 ($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;
75 $DEBUG = 0 unless defined $DEBUG;
78 # This is the class_modular namespace, so we don't muck up the
79 # subclass(es) by accident.
81 my $cm = q(__class_modular);
89 $obj = Foo::Bar->new();
93 Creates a new Foo::Bar object
95 Aditional arguments can be passed to this creator, and they are stored
96 in $self->{creation_args} (and $self->{$cm}{creation_args} by
97 _init. You can also override the new method in your subclass. It's
98 just provided here for completeness.
103 my ($class,@args) = @_;
105 # We shouldn't be called $me->new, but just in case
106 $class = ref($class) || $class;
125 Stores the arguments used at new so modules that are loaded later can
126 read them from B<creation_args>
128 You can also override this method, but if you do so, you should call
129 Class::Modular::_init($self,@_) if you don't set creation_args.
134 my ($self,@creation_args) = @_;
136 my $creation_args = [@_];
137 $self->{creation_args} = $creation_args if not exists $self->{creation_args};
139 # Make another reference to this, so we can get it if a subclass
140 # overwrites it, or if it was already set for some reason
141 $self->{$cm}->{creation_args} = $creation_args;
149 $db->load('FOO::Subclass');
153 Loads the named subclass into this object if the named subclass has
156 The options scalar is passed to $subclass::_methods when determining
157 which methods should be added using _addmethods.
159 The subclasses _init method is called right after methods are loaded.
161 If debugging is enabled, will warn about loading already loaded
168 my ($self,$subclass,$options) = @_;
172 # check to see if the subclass has already been loaded.
174 if (not defined $self->{$cm}{_subclasses}{$subclass}){
177 # Yeah, I don't care if calling an inherited AUTOLOAD
178 # for a non method is deprecated. Bite me.
179 no warnings 'deprecated';
180 eval "require $subclass" or die $@;
181 $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
182 &{"${subclass}::_init"}($self);
184 die $@ if $@ and $@ !~ /^Undefined function ${subclass}::_init at [^\n]*$/;
185 $self->{$cm}{_subclasses}{$subclass} = {};
188 carp "Not reloading subclass $subclass" if $DEBUG;
200 Given an array of methods, adds the methods into the _methodhash
203 Methods that have previously been overridden by override are _NOT_
204 overridden again. This may need to be adjusted in load.
208 sub _addmethods($@) {
209 my ($self,$subclass,@methods) = @_;
211 # stick the method into the table
212 # DLA: Make with the munchies!
214 foreach my $method (@methods) {
215 if (not $method =~ /^$subclass/) {
216 $method = $subclass.'::'.$method;
218 my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
219 if (exists $self->{$cm}{_methodhash}{$method_name}) {
220 if ($self->{$cm}{_methodhash}{$method_name}{overridden}) {
221 carp "Not overriding already overriden method $method_name\n" if $DEBUG;
224 carp "Overriding $method_name $self->{$cm}{_methodhash}{$method_name}{reference} with $method\n";
226 $self->{$cm}{_methodhash}{$method_name}{reference} = $method;
227 $self->{$cm}{_methodhash}{$method_name}{subclass} = $subclass;
236 $obj->override('methodname', $code_ref)
240 TRUE on success, FALSE on failure.
244 Allows you to override utility functions that are called internally to
245 provide a different default function.
247 It's superficially similar to _addmethods, which is called by load,
248 but it deals with code references, and requires the method name to be
251 Methods overridden here are _NOT_ overrideable in _addmethods. This
252 may need to be changed.
257 my ($self, $method_name, $function_reference) = @_;
259 $self->{$cm}{_methodhash}{$method_name}{reference} = $function_reference;
260 $self->{$cm}{_methodhash}{$method_name}{overridden} = 1;
267 my $clone = $obj->clone
271 Produces a clone of the object with duplicates of all data and/or new
272 connections as appropriate.
274 Calls _clone on all loaded subclasses.
276 Warns if debugging is on for classes which don't have a _clone
277 method. Dies on other errors.
285 bless $clone, ref($self);
287 # copy data structures at this level
288 $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
289 $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
291 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
292 # Find out if the subclass has a clone method.
293 # If it does, call it, die on errors.
294 my $function = UNIVERSAL::can($subclass, '_clone');
297 # No, I could care less that AUTOLOAD is
298 # deprecated. Eat me.
299 no warnings 'deprecated';
300 &{"${subclass}::_clone"}($self,$clone);
303 # Die unless we've hit an undefined subroutine.
304 if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){
305 die "Failed while trying to clone: $@";
308 carp "No _clone method defined for $subclass" if $DEBUG;
319 Class::Modular->can('METHOD');
323 Replaces UNIVERSAL's can method so that handled methods are reported
324 correctly. Calls UNIVERSAL::can in the places where we don't know
329 A coderef to the method if the method is supported, undef otherwise.
338 my ($self,$method,$vars) = @_;
340 croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method;
342 if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) {
343 # If the method is defined, return a reference to the
345 return $self->{$cm}{_methodhash}{$method}{reference};
348 # Otherwise, let UNIVERSAL::can deal with the method
350 return UNIVERSAL::can($self,$method);
358 $obj->handledby('methodname');
359 $obj->handledby('Class::Method::methodname');
363 Returns the subclass that handles this method.
376 my ($self,$method_name) = @_;
378 $method_name =~ s/.*\://;
380 if (exists $self->{$cm}{_methodhash}{$method_name}) {
381 return $self->{$cm}{_methodhash}{$method_name}{subclass};
395 Calls all subclass _destroy methods.
397 Subclasses need only implement a _destroy method if they have
398 references that need to be uncircularized, or things that should be
399 disconnected or closed.
405 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
406 # use eval to try and call the subclasses _destroy method.
407 # Ignore no such function errors, but trap other types of
411 &{"${subclass}::_destroy"}($self);
414 if ($@ !~ /^Undefined function ${subclass}::_destroy at [^\n]*$/){
415 die "Failed while trying to destroy: $@";
418 carp "No _destroy method defined for $subclass" if $DEBUG;
427 The AUTOLOAD function is responsible for calling child methods which
428 have been installed into the current Class::Modular handle.
430 Subclasses that have a new function as well as an AUTOLOAD function
431 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
433 $Class::Modular::AUTOLOAD = $AUTOLOAD;
434 goto &Class::Modular::AUTOLOAD;
439 my $method = $AUTOLOAD;
445 if (not ref($self)) {
446 carp "Not a reference in AUTOLOAD.";
450 if (exists $self->{$cm}{_methodhash}{$method} and
451 defined $self->{$cm}{_methodhash}{$method}{reference}) {
454 goto &{$self->{$cm}{_methodhash}{$method}{reference}};
458 croak "Undefined function $AUTOLOAD";
469 Because this module works through AUTOLOAD, utilities that use
470 can($object) instead of $object->can() will fail to see routines that
471 are actually there. Params::Validate, an excellent module, is
472 currently one of these offenders.
476 This module is part of DA, Don Armstrong's Modules, and is released
477 under the terms of the GPL version 2, or any later version. See the
478 file README and COPYING for more information.
480 Copyright 2003, 2004 by Don Armstrong <don@donarmstrong.com>