# This module is part of DA, Don Armstrong's Modules, and is released
# under the terms of the GPL version 2, or any later version. See the
-# file README and COPYING for more information. Copyright 2003 by Don
-# Armstrong <don@donarmstrong.com>.
+# file README and COPYING for more information.
+# Copyright 2003,2005 by Don Armstrong <don@donarmstrong.com>.
# $Id$
package Class::Modular;
=head1 SYNOPSIS
-package Foo::Bar;
+ package Foo;
-@ISA = qw(Class::Modular);
+ use base qw(Class::Modular);
+
+ use vars (@METHODS);
+ BEGIN{@METHODS=qw(blah)};
+
+ sub blah{
+ my $self = shift;
+ return 1;
+ }
+
+ [...]
+
+ package Bar;
+
+ sub method_that_bar_provides{
+ print qq(Hello World!\n);
+ }
+
+ sub _methods($$){
+ return qw(method_that_bar_provides);
+ }
+
+ [...]
+
+ use Foo;
+
+ $foo = new Foo;
+ $foo->load('Bar');
+ $foo->blah && $foo->method_that_bar_provides;
=head1 DESCRIPTION
without modifying the base classes. This allows for code to be more
modular, and reduces code duplication.
-=over
-
-=item new
-
-new is responsible for blessing and creating a new database superclass.
-
-=item load
-
-load is responsible for loading database plugins
-
-=back
-
+This module attempts to fill the middle ground between
+L<Class::Mutator> and true classless OOP, like L<Class::Classless>.
=head1 FUNCTIONS
=cut
use strict;
-use vars qw($VERSION $DEBUG);
+use vars qw($VERSION $DEBUG $REVISION $USE_SAFE);
use Carp;
use Storable qw(dclone); # Used for deep copying objects
+use Safe; # Use Safe when we are dealing with coderefs
BEGIN{
- $VERSION = '0.1';
+ $VERSION = q$0.06SVN$;
($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;
$DEBUG = 0 unless defined $DEBUG;
+ $USE_SAFE = 1 unless defined $USE_SAFE;
}
-our $AUTOLOAD;
-
-=head2 new
+# This is the class_modular namespace, so we don't muck up the
+# subclass(es) by accident.
- Title : new
- Usage : $obj = Foo::Bar->new();
- Function: Creates a new Foo::Bar object
- Returns : A new Foo::Bar object
- Args : none.
+my $cm = q(__class_modular);
- Aditional arguments can be passed to this creator, and they are
- stored in $self->{_creation_args}. You can also override the new
- method in your subclass. It's just provided here for completeness.
+our $AUTOLOAD;
-=cut
-sub new {
- my ($class,@args) = @_;
+=head2 load
- # We shouldn't be called $me->new, but just in case
- $class = ref($class) || $class;
+ $cm->load('Subclass');
+ # or
+ $cm->load('Subclass',$options);
- my $self = {};
- bless $self, $class;
+Loads the named Subclass into this object if the named Subclass has
+not been loaded.
- $self->_init(@args);
+If debugging is enabled, will warn about loading already loaded
+subclasses. Use C<$cm->is_loaded('Subclass')> to avoid these warnings.
- return $self;
-}
+=head3 Methods
+If the subclass has a C<_methods> function (or at least,
+UNIVERSAL::can thinks it does), C<_methods> is called to return a LIST
+of methods that the subclass wishes to handle. The L<Class::Modular>
+object and the options SCALAR are passed to the _methods function.
-=head2 _init
+If the subclass does not have a C<_methods> function, then the array
+C<@{"${subclass}::METHODS"}> is used to determine the methods that the
+subclass will handle.
-=head3 Usage
+=head3 _init and required submodules
- $self->_init(@args);
+If the subclass has a C<_init> function (or at least, UNIVERSAL::can
+thinks it does), C<_init> is called right after the module is
+loaded. The L<Class::Modular> object and the options SCALAR are passed
+to the _methods function. Typical uses for this call are to load other
+required submodules.
-=head3 Function
+As this is the most common thing to do in C<_init>, if a subclass
+doesn't have one, then the array C<@{"${subclass}::SUB_MODULES"}> is
+used to determine the subclass that need to be loaded:
-Stores the arguments used at new so modules that are loaded later can
-read them
+ for my $module (@{"${subclass}::SUB_MODULES"}) {
+ $self->is_loaded($module) || $self->load($module);
+ }
=cut
-sub _init {
- my ($self,@creation_args) = @_;
-
- $self->{creation_args} = [@_];
-}
-
-
-=head2 load
-
- Title : load
- Usage : $db->load('FOO::Subclass');
- Function: loads a Class::Modular subclass
- Returns : nothing
- Args : SCALAR subclass SCALAR options
-
- Loads the named subclass into this object if the named subclass has
- not been loaded.
-
- The options scalar is passed to $subclass::_methods when determining
- which methods should be added using _addmethods.
-
- The subclasses _init method is called right after methods are loaded.
-
- If debugging is enabled, will warn about loading already loaded
- subclasses.
-
-=cut
-
-
sub load($$;$) {
my ($self,$subclass,$options) = @_;
# check to see if the subclass has already been loaded.
- if (not defined $self->{_subclasses}->{$subclass}){
+ if (not defined $self->{$cm}{_subclasses}{$subclass}){
eval {
no strict 'refs';
+ # Yeah, I don't care if calling an inherited AUTOLOAD
+ # for a non method is deprecated. Bite me.
+ no warnings 'deprecated';
eval "require $subclass" or die $@;
- $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
- &{"${subclass}::_init"}($self);
+ # We should read @METHODS and @SUB_MODULES and just do
+ # the right thing if at all possible.
+ my $methods = can($subclass,"_methods");
+ if (defined $methods) {
+ $self->_addmethods($subclass,&$methods($self,$options));
+ }
+ else {
+ $self->_addmethods($subclass,@{"${subclass}::METHODS"})
+ }
+ my $init = can($subclass,"_init");
+ if (defined $init) {
+ &$init($self,$options);
+ }
+ else {
+ for my $module (@{"${subclass}::SUB_MODULES"}) {
+ $self->is_loaded($module) || $self->load($module);
+ }
+ }
};
die $@ if $@;
- $self->{_subclasses}->{$subclass} = {};
+ $self->{$cm}{_subclasses}{$subclass} ||= {};
}
else {
carp "Not reloading subclass $subclass" if $DEBUG;
}
}
-=head2 _addmethods
+=head2 is_loaded
- Title : _addmethods
- Usage : $self->_addmethods()
- Function: Adds the passed methods into the function table
- Returns :
- Args : ARRAY of methods
+ if ($cm->is_loaded('Subclass')) {
+ # do something
+ }
- Given an array of methods, adds the methods into the _methodhash
- calling table.
+Tests to see if the named subclass is loaded.
- Methods that have previously been overridden by override are _NOT_
- overridden again. This may need to be adjusted in load.
+Returns 1 if the subclass has been loaded, 0 otherwise.
=cut
-sub _addmethods($@) {
- my ($self,$subclass,@methods) = @_;
-
- # stick the method into the table
- # DLA: Make with the munchies!
-
- foreach my $method (@methods) {
- if (not $method =~ /^$subclass/) {
- $method = $subclass.'::'.$method;
- }
- my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
- if (exists $self->{_methodhash}->{$method_name}) {
- if ($self->{_methodhash}->{$method_name}->{overridden}) {
- carp "Not overriding already overriden method $method_name\n" if $DEBUG;
- next;
- }
- carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
- }
- $self->{_methodhash}->{$method_name}->{reference} = $method;
- $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
- }
+sub is_loaded($$){
+ my ($self,$subclass) = @_;
+ # An entry will exist in the _subclasses hashref only if
+ return 1 if exists $self->{$cm}{_subclasses}{$subclass}
+ and defined $self->{$cm}{_subclasses}{$subclass};
+ return 0;
}
=head2 override
- Title : override
- Usage : $obj->override('methodname', $code_ref)
- Function: Overrides the method methodname and calls $code_ref instead.
- Returns : TRUE on success, FALSE on failure.
- Args : SCALAR method name
- CODEREF function reference
-
- Allows you to override utility functions that are called internally
- to provide a different default function.
+ $obj->override('methodname', $code_ref)
- It's superficially similar to _addmethods, which is called by load,
- but it deals with code references, and requires the method name to be
- known.
+Allows you to override utility functions that are called internally to
+provide a different default function. It's superficially similar to
+_addmethods, which is called by load, but it deals with code
+references, and requires the method name to be known.
- Methods overridden here are _NOT_ overrideable in _addmethods. This
- may need to be changed.
+Methods overridden here are _NOT_ overrideable in _addmethods. This
+may need to be changed.
=cut
sub override {
my ($self, $method_name, $function_reference) = @_;
- $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
- $self->{_methodhash}->{$method_name}->{overridden} = 1;
+ $self->{$cm}{_methodhash}{$method_name}{reference} = $function_reference;
+ $self->{$cm}{_methodhash}{$method_name}{overridden} = 1;
}
+
=head2 clone
- Title : clone
- Usage : my $clone = $obj->clone
- Function: Produces a clone of the Class::Modular object
- Returns :
- Args :
+ my $clone = $obj->clone
- Produces a clone of the object with duplicates of all data and/or new
- connections as appropriate.
+Produces a clone of the object with duplicates of all data and/or new
+connections as appropriate.
- Calls _clone on all loaded subclasses.
+Calls _clone on all loaded subclasses.
- Warns if debugging is on for classes which don't have a _clone
- method. Dies on other errors.
+Warns if debugging is on for classes which don't have a _clone method.
+Dies on other errors.
+
+clone uses L<Safe> to allow L<Storable> to deparse code references
+sanely. Set C<$Class::Modular::USE_SAFE = 0> to disable this. [Doing
+this may cause errors from Storable about CODE references.]
=cut
bless $clone, ref($self);
# copy data structures at this level
- $clone->{_methodhash} = dclone($self->{_methodhash});
- $clone->{_subclasses} = dclone($self->{_subclasses});
-
- foreach my $subclass (keys %{$self->{_subclasses}}) {
- # use eval to try and call the subclasses _clone method.
- # Ignore no such function errors, but trap other types of
- # errors.
+ if ($self->{$cm}{use_safe}) {
+ my $safe = new Safe;
+ $safe->permit(qw(:default require));
+ local $Storable::Deparse = 1;
+ local $Storable::Eval = sub { $safe->reval($_[0]) };
+ $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
+ $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
+ }
+ else {
+ $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
+ $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
+ }
- # XXX Switch to can instead.
+ foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
+ # Find out if the subclass has a clone method.
+ # If it does, call it, die on errors.
+ my $function = UNIVERSAL::can($subclass, '_clone');
eval {
no strict 'refs';
- &$subclass::_clone($self,$clone);
+ # No, I could care less that AUTOLOAD is
+ # deprecated. Eat me.
+ no warnings 'deprecated';
+ &{"${subclass}::_clone"}($self,$clone);
};
if ($@) {
# Die unless we've hit an undefined subroutine.
- die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
- warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
+ if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){
+ die "Failed while trying to clone: $@";
+ }
+ else {
+ carp "No _clone method defined for $subclass" if $DEBUG;
+ }
}
-
-
}
}
-=head2 can
-=head3 Usage
+=head2 can
$obj->can('METHOD');
Class::Modular->can('METHOD');
-=head3 Function
-
Replaces UNIVERSAL's can method so that handled methods are reported
correctly. Calls UNIVERSAL::can in the places where we don't know
anything it doesn't.
-=head3 Returns
-
-A coderef to the method if the method is supported, undef otherwise.
-
-=head3 Args
-
-Scalar Method Name
+Returns a coderef to the method if the method is supported, undef
+otherwise.
=cut
sub can{
my ($self,$method,$vars) = @_;
- if (ref $self and exists $self->{_methodhash}->{$method}) {
+ croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method;
+
+ if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) {
# If the method is defined, return a reference to the
# method.
- return $self->{_methodhash}->{$method}->{reference};
+ return $self->{$cm}{_methodhash}{$method}{reference};
}
else {
# Otherwise, let UNIVERSAL::can deal with the method
}
}
-=head2 handledby
+=head2 isa
-=head3 Usage
+ $obj->isa('TYPE');
+ Class::Modular->isa('TYPE');
- $obj->handledby('methodname');
- $obj->handledby('Class::Method::methodname');
+Replaces UNIVERSAL's isa method with one that knows which modules have
+been loaded into this object. Calls C<is_loaded> with the type passed,
+then calls UNIVERSAL::isa if the type isn't loaded.
+
+=cut
-=head3 Function
+sub isa{
+ my ($self,$type) = @_;
+
+ croak "Usage: isa(object-ref, type);\n" if not defined $type;
+
+ return $self->is_loaded($type) || UNIVERSAL::isa($self,$type);
+}
-Returns the subclass that handles this method.
-=head3 Returns
-SCALAR subclass name
+=head2 handledby
-=head3 Args
+ $obj->handledby('methodname');
+ $obj->handledby('Class::Method::methodname');
-SCALAR method name
+Returns the subclass that handles the method methodname.
=cut
$method_name =~ s/.*\://;
- if (exists $self->{_methodhash}->{$method_name}) {
- return $self->{_methodhash}->{$method_name}->{subclass};
+ if (exists $self->{$cm}{_methodhash}{$method_name}) {
+ return $self->{$cm}{_methodhash}{$method_name}{subclass};
}
return undef;
}
-=head2 DESTROY
+=head2 new
+
+ $obj = Foo::Bar->new(qw(baz quux));
-=head3 Usage
+Creates a new Foo::Bar object
-Called by perl.
+Aditional arguments can be passed to this creator, and they are stored
+in $self->{creation_args} (and $self->{$cm}{creation_args} by
+_init.
+
+This new function creates an object of Class::Modular, and calls the
+C<$self->load(Foo::Bar)>, which will typically do what you want.
+
+If you override this method in your subclasses, you will not be able
+to use override to override methods defined within those
+subclasses. This may or may not be a feature. You must also call
+C<$self->SUPER::_init(@_)> if you override new.
+
+=cut
+
+sub new {
+ my ($class,@args) = @_;
+
+ # We shouldn't be called $me->new, but just in case
+ $class = ref($class) || $class;
+
+ my $self = {};
-=head3 Function
+ # But why, Don, are you being evil and not using the two argument
+ # bless properly?
+
+ # My child, we always want to go to Class::Modular first,
+ # otherwise we will be unable to override methods in subclasses.
+
+ # But doesn't this mean that subclasses won't be able to override
+ # us?
+
+ # Only if they don't also override new!
+
+ bless $self, 'Class::Modular';
+
+ $self->_init(@args);
+
+ # Now we call our subclass's load routine so that our evil deeds
+ # are masked
+
+ $self->load($class);
+
+ return $self;
+}
+
+
+=head1 FUNCTIONS YOU PROBABLY DON'T CARE ABOUT
+
+=head2 DESTROY
+
+ undef $foo;
Calls all subclass _destroy methods.
sub DESTROY{
my $self = shift;
- foreach my $subclass (keys %{$self->{_subclasses}}) {
+ foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
# use eval to try and call the subclasses _destroy method.
# Ignore no such function errors, but trap other types of
# errors.
eval {
no strict 'refs';
- &$subclass::_destroy($self);
+ # Shove off, deprecated AUTOLOAD warning!
+ no warnings 'deprecated';
+ &{"${subclass}::_destroy"}($self);
};
if ($@) {
- # Die unless we've hit an undefined subroutine.
- die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
- warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
+ if ($@ !~ /^Undefined (function|subroutine) \&?${subclass}::_destroy (|called )at [^\n]*$/){
+ die "Failed while trying to destroy: $@";
+ }
+ else {
+ carp "No _destroy method defined for $subclass" if $DEBUG;
+ }
}
}
}
=head2 AUTOLOAD
- Title : AUTOLOAD
- Usage : Called by perl
- Function: Calls child methods which have been installed into this handle
- Returns : N/A
- Args : N/A
-
The AUTOLOAD function is responsible for calling child methods which
have been installed into the current Class::Modular handle.
$Class::Modular::AUTOLOAD = $AUTOLOAD;
goto &Class::Modular::AUTOLOAD;
+Failure to do the above will break Class::Modular utterly.
+
=cut
sub AUTOLOAD{
return;
}
- if (exists $self->{_methodhash}->{$method} and
- defined $self->{_methodhash}->{$method}->{reference}) {
- eval {
- no strict 'refs';
- goto &{$self->{_methodhash}{$method}{reference}};
+ if (exists $self->{$cm}{_methodhash}{$method} and
+ defined $self->{$cm}{_methodhash}{$method}{reference}) {
+ {
+ my $method = \&{$self->{$cm}{_methodhash}{$method}{reference}};
+ goto &$method;
}
}
else {
}
}
+=head2 _init
+
+ $self->_init(@args);
+
+Stores the arguments used at new so modules that are loaded later can
+read them from B<creation_args>
+
+You can also override this method, but if you do so, you should call
+Class::Modular::_init($self,@_) if you don't set creation_args.
+
+=cut
+
+sub _init {
+ my ($self,@creation_args) = @_;
+
+ my $creation_args = [@_];
+ $self->{creation_args} = $creation_args if not exists $self->{creation_args};
+
+ # Make another reference to this, so we can get it if a subclass
+ # overwrites it, or if it was already set for some reason
+ $self->{$cm}->{creation_args} = $creation_args;
+ $self->{$cm}->{use_safe} = $USE_SAFE;
+}
+
+
+=head2 _addmethods
+
+ $self->_addmethods()
+
+Given an array of methods, adds the methods into the _methodhash
+calling table.
+
+Methods that have previously been overridden by override are _NOT_
+overridden again. This may need to be adjusted in load.
+
+=cut
+
+sub _addmethods($@) {
+ my ($self,$subclass,@methods) = @_;
+
+ # stick the method into the table
+ # DLA: Make with the munchies!
+
+ foreach my $method (@methods) {
+ if (not $method =~ /^$subclass/) {
+ $method = $subclass.'::'.$method;
+ }
+ my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
+ if (exists $self->{$cm}{_methodhash}{$method_name}) {
+ if ($self->{$cm}{_methodhash}{$method_name}{overridden}) {
+ carp "Not overriding already overriden method $method_name\n" if $DEBUG;
+ next;
+ }
+ carp "Overriding $method_name $self->{$cm}{_methodhash}{$method_name}{reference} with $method\n";
+ }
+ $self->{$cm}{_methodhash}{$method_name}{reference} = $method;
+ $self->{$cm}{_methodhash}{$method_name}{subclass} = $subclass;
+ }
+
+}
+
1;
__END__
+=head1 BUGS
+Because this module works through AUTOLOAD, utilities that use
+can($object) instead of $object->can() will fail to see routines that
+are actually there. Params::Validate, an excellent module, is
+currently one of these offenders.
+
+=head1 COPYRIGHT
+
+This module is part of DA, Don Armstrong's Modules, and is released
+under the terms of the GPL version 2, or any later version. See the
+file README and COPYING for more information.
+
+Copyright 2003, 2005 by Don Armstrong <don@donarmstrong.com>
+
+=cut
projects / class_modular.git / .git / blobdiff