1 # This file is part of Class::Modular and is released under the terms
2 # of the GPL version 2, or any later version at your option. 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 Class::Modular is a superclass for generating modular classes, where
22 methods can be added into the class from the perspective of the
23 object, rather than the perspective of the class.
25 That is, you can create a class which has a set of generic common
26 functions. Less generic functions can be included or overridden
27 without modifying the base classes. This allows for code to be more
28 modular, and reduces code duplication.
30 It fills the middle ground between traditional class based OOP and
31 classless OOP. L<Class::Mutator> and L<Sex> are similar to
32 Class::Modular but less manic.
39 use vars qw($VERSION $DEBUG $REVISION);
43 use Storable qw(dclone); # Used for deep copying objects
47 ($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;
48 $DEBUG = 0 unless defined $DEBUG;
57 $obj = Foo::Bar->new();
61 Creates a new C<Foo::Bar> object.
63 Aditional arguments can be passed to this creator, and they are stored
64 in C<$self->{_creation_args}>. You can also override the new method in
65 your subclass. It's just provided here for completeness.
70 my ($class,@args) = @_;
72 # We shouldn't be called $me->new, but just in case
73 $class = ref($class) || $class;
92 Stores the arguments used at new so modules that are loaded later can
98 my ($self,@creation_args) = @_;
100 $self->{creation_args} = [@_];
108 $db->load('FOO::Subclass');
112 Loads the named subclass into this object if the named subclass has
115 The options scalar is passed to $subclass::_methods when determining
116 which methods should be added using _addmethods.
118 The subclasses _init method is called right after methods are loaded.
120 If debugging is enabled, will warn about loading already loaded
127 my ($self,$subclass,$options) = @_;
131 # check to see if the subclass has already been loaded.
133 if (not defined $self->{_subclasses}->{$subclass}){
136 eval "require $subclass" or die $@;
137 # Use subclass::METHODS if it exists [use constants METHODS => qw(foo)]
138 $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
139 &{"${subclass}::_init"}($self);
142 $self->{_subclasses}->{$subclass} = {};
145 carp "Not reloading subclass $subclass" if $DEBUG;
153 $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
157 Given an array of methods, adds the methods into the _methodhash
160 Methods that have previously been overridden by override are _NOT_
161 overridden again. This may need to be adjusted in load.
165 sub _addmethods($@) {
166 my ($self,$subclass,@methods) = @_;
168 # stick the method into the table
169 # DLA: Make with the munchies!
171 foreach my $method (@methods) {
172 if (not $method =~ /^$subclass/) {
173 $method = $subclass.'::'.$method;
175 my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
176 if (exists $self->{_methodhash}->{$method_name}) {
177 if ($self->{_methodhash}->{$method_name}->{overridden}) {
178 carp "Not overriding already overriden method $method_name\n" if $DEBUG;
181 carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
183 $self->{_methodhash}->{$method_name}->{reference} = $method;
184 $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
193 $obj->override('methodname', $code_ref)
197 Allows you to override utility functions that are called internally to
198 provide a different default function.
200 It's superficially similar to _addmethods, which is called by load,
201 but it deals with code references, and requires the method name to be
204 Methods overridden here are _NOT_ overrideable in _addmethods. This
205 may need to be changed.
210 my ($self, $method_name, $function_reference) = @_;
212 $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
213 $self->{_methodhash}->{$method_name}->{overridden} = 1;
220 my $clone = $obj->clone
224 Produces a clone of the object with duplicates of all data and/or new
225 connections as appropriate.
227 Calls _clone on all loaded subclasses.
229 Warns if debugging is on for classes which don't have a _clone method.
230 Dies on other errors.
238 bless $clone, ref($self);
240 # copy data structures at this level
241 $clone->{_methodhash} = dclone($self->{_methodhash});
242 $clone->{_subclasses} = dclone($self->{_subclasses});
244 foreach my $subclass (keys %{$self->{_subclasses}}) {
245 # use eval to try and call the subclasses _clone method.
246 # Ignore no such function errors, but trap other types of
249 # XXX Switch to can instead.
252 &$subclass::_clone($self,$clone);
255 # Die unless we've hit an undefined subroutine.
256 die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
257 warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
269 Class::Modular->can('METHOD');
273 Replaces UNIVERSAL's can method so that handled methods are reported
274 correctly. Calls UNIVERSAL::can in the places where we don't know
279 A coderef to the method if the method is supported, undef otherwise.
288 my ($self,$method,$vars) = @_;
290 if (ref $self and exists $self->{_methodhash}->{$method}) {
291 # If the method is defined, return a reference to the
293 return $self->{_methodhash}->{$method}->{reference};
296 # Otherwise, let UNIVERSAL::can deal with the method
298 return UNIVERSAL::can($self,$method);
306 $obj->handledby('methodname');
307 $obj->handledby('Class::Method::methodname');
311 Returns the subclass that handles this method.
324 my ($self,$method_name) = @_;
326 $method_name =~ s/.*\://;
328 if (exists $self->{_methodhash}->{$method_name}) {
329 return $self->{_methodhash}->{$method_name}->{subclass};
343 Calls all subclass _destroy methods.
345 Subclasses need only implement a _destroy method if they have
346 references that need to be uncircularized, or things that should be
347 disconnected or closed.
353 foreach my $subclass (keys %{$self->{_subclasses}}) {
354 # use eval to try and call the subclasses _destroy method.
355 # Ignore no such function errors, but trap other types of
359 &$subclass::_destroy($self);
362 # Die unless we've hit an undefined subroutine.
363 die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
364 warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
374 The AUTOLOAD function is responsible for calling child methods which
375 have been installed into the current Class::Modular handle.
377 Subclasses that have a new function as well as an AUTOLOAD function
378 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
380 $Class::Modular::AUTOLOAD = $AUTOLOAD;
381 goto &Class::Modular::AUTOLOAD;
386 my $method = $AUTOLOAD;
392 if (not ref($self)) {
393 carp "Not a reference in AUTOLOAD.";
397 if (exists $self->{_methodhash}->{$method} and
398 defined $self->{_methodhash}->{$method}->{reference}) {
401 goto &{$self->{_methodhash}{$method}{reference}};
405 croak "Undefined function $AUTOLOAD";