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. Copyright 2003 by Don
4 # Armstrong <don@donarmstrong.com>.
7 package Class::Modular;
11 Class::Modular -- Modular class generation superclass
17 use base qw(Class::Modular);
25 $foo->method_that_bar_provides;
30 Class::Modular is a superclass for generating modular classes, where
31 methods can be added into the class from the perspective of the
32 object, rather than the perspective of the class.
34 That is, you can create a class which has a set of generic common
35 functions. Less generic functions can be included or overridden
36 without modifying the base classes. This allows for code to be more
37 modular, and reduces code duplication.
44 use vars qw($VERSION $DEBUG $REVISION);
48 use Storable qw(dclone); # Used for deep copying objects
52 ($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;
53 $DEBUG = 0 unless defined $DEBUG;
56 # This is the class_modular namespace, so we don't muck up the
57 # subclass(es) by accident.
59 my $cm = q(__class_modular);
67 $obj = Foo::Bar->new();
71 Creates a new Foo::Bar object
73 Aditional arguments can be passed to this creator, and they are stored
74 in $self->{creation_args} (and $self->{$cm}{creation_args} by
75 _init. You can also override the new method in your subclass. It's
76 just provided here for completeness.
81 my ($class,@args) = @_;
83 # We shouldn't be called $me->new, but just in case
84 $class = ref($class) || $class;
103 Stores the arguments used at new so modules that are loaded later can
104 read them from B<creation_args>
106 You can also override this method, but if you do so, you should call
107 Class::Modular::_init(@_) if you don't set creation_args.
112 my ($self,@creation_args) = @_;
114 my $creation_args = [@_];
115 $self->{creation_args} = $creation_args if not exists $self->{creation_args};
117 # Make another reference to this, so we can get it if a subclass
118 # overwrites it, or if it was already set for some reason
119 $self->{$cm}->{creation_args} = $creation_args;
127 $db->load('FOO::Subclass');
131 Loads the named subclass into this object if the named subclass has
134 The options scalar is passed to $subclass::_methods when determining
135 which methods should be added using _addmethods.
137 The subclasses _init method is called right after methods are loaded.
139 If debugging is enabled, will warn about loading already loaded
146 my ($self,$subclass,$options) = @_;
150 # check to see if the subclass has already been loaded.
152 if (not defined $self->{$cm}{_subclasses}->{$subclass}){
155 # Yeah, I don't care if calling an inherited AUTOLOAD
156 # for a non method is deprecated. Bite me.
157 no warnings 'deprecated';
158 eval "require $subclass" or die $@;
159 $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
160 &{"${subclass}::_init"}($self);
162 die $@ if $@ and $@ !~ /^Undefined function ${subclass}::_init at [^\n]*$/;
163 $self->{$cm}{_subclasses}->{$subclass} = {};
166 carp "Not reloading subclass $subclass" if $DEBUG;
178 Given an array of methods, adds the methods into the _methodhash
181 Methods that have previously been overridden by override are _NOT_
182 overridden again. This may need to be adjusted in load.
186 sub _addmethods($@) {
187 my ($self,$subclass,@methods) = @_;
189 # stick the method into the table
190 # DLA: Make with the munchies!
192 foreach my $method (@methods) {
193 if (not $method =~ /^$subclass/) {
194 $method = $subclass.'::'.$method;
196 my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
197 if (exists $self->{$cm}{_methodhash}->{$method_name}) {
198 if ($self->{$cm}{_methodhash}->{$method_name}->{overridden}) {
199 carp "Not overriding already overriden method $method_name\n" if $DEBUG;
202 carp "Overriding $method_name $self->{$cm}{_methodhash}->{$method_name}->{reference} with $method\n";
204 $self->{$cm}{_methodhash}->{$method_name}->{reference} = $method;
205 $self->{$cm}{_methodhash}->{$method_name}->{subclass} = $subclass;
214 $obj->override('methodname', $code_ref)
218 TRUE on success, FALSE on failure.
222 Allows you to override utility functions that are called internally to
223 provide a different default function.
225 It's superficially similar to _addmethods, which is called by load,
226 but it deals with code references, and requires the method name to be
229 Methods overridden here are _NOT_ overrideable in _addmethods. This
230 may need to be changed.
235 my ($self, $method_name, $function_reference) = @_;
237 $self->{$cm}{_methodhash}->{$method_name}->{reference} = $function_reference;
238 $self->{$cm}{_methodhash}->{$method_name}->{overridden} = 1;
245 my $clone = $obj->clone
249 Produces a clone of the object with duplicates of all data and/or new
250 connections as appropriate.
252 Calls _clone on all loaded subclasses.
254 Warns if debugging is on for classes which don't have a _clone
255 method. Dies on other errors.
263 bless $clone, ref($self);
265 # copy data structures at this level
266 $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
267 $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
269 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
270 # Find out if the subclass has a clone method.
271 # If it does, call it, die on errors.
272 my $function = UNIVERSAL::can($subclass, '_clone');
275 # No, I could care less that AUTOLOAD is
276 # deprecated. Eat me.
277 no warnings 'deprecated';
278 &{"${subclass}::_clone"}($self,$clone);
281 # Die unless we've hit an undefined subroutine.
282 if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){
283 die "Failed while trying to clone: $@";
286 carp "No _clone method defined for $subclass" if $DEBUG;
297 Class::Modular->can('METHOD');
301 Replaces UNIVERSAL's can method so that handled methods are reported
302 correctly. Calls UNIVERSAL::can in the places where we don't know
307 A coderef to the method if the method is supported, undef otherwise.
316 my ($self,$method,$vars) = @_;
318 croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method;
320 if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) {
321 # If the method is defined, return a reference to the
323 return $self->{$cm}{_methodhash}->{$method}->{reference};
326 # Otherwise, let UNIVERSAL::can deal with the method
328 return UNIVERSAL::can($self,$method);
336 $obj->handledby('methodname');
337 $obj->handledby('Class::Method::methodname');
341 Returns the subclass that handles this method.
354 my ($self,$method_name) = @_;
356 $method_name =~ s/.*\://;
358 if (exists $self->{$cm}{_methodhash}->{$method_name}) {
359 return $self->{$cm}{_methodhash}->{$method_name}->{subclass};
373 Calls all subclass _destroy methods.
375 Subclasses need only implement a _destroy method if they have
376 references that need to be uncircularized, or things that should be
377 disconnected or closed.
383 foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
384 # use eval to try and call the subclasses _destroy method.
385 # Ignore no such function errors, but trap other types of
389 &{"${subclass}::_destroy"}($self);
392 if ($@ !~ /^Undefined function ${subclass}::_destroy at [^\n]*$/){
393 die "Failed while trying to destroy: $@";
396 carp "No _destroy method defined for $subclass" if $DEBUG;
405 The AUTOLOAD function is responsible for calling child methods which
406 have been installed into the current Class::Modular handle.
408 Subclasses that have a new function as well as an AUTOLOAD function
409 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
411 $Class::Modular::AUTOLOAD = $AUTOLOAD;
412 goto &Class::Modular::AUTOLOAD;
417 my $method = $AUTOLOAD;
423 if (not ref($self)) {
424 carp "Not a reference in AUTOLOAD.";
428 if (exists $self->{$cm}{_methodhash}->{$method} and
429 defined $self->{$cm}{_methodhash}->{$method}->{reference}) {
432 goto &{$self->{$cm}{_methodhash}{$method}{reference}};
436 croak "Undefined function $AUTOLOAD";