X-Git-Url: https://git.donarmstrong.com/?p=class_modular.git%2F.git;a=blobdiff_plain;f=lib%2FClass%2FModular.pm;h=ec58bb485837789ca50dbfc0c0b895df83c098ba;hp=4bd2d15a0be7987472ec552c28feba31ea8b1a49;hb=HEAD;hpb=1dd2726e3c9979f51413e9d82b9e0f335544d62a diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm index 4bd2d15..ec58bb4 100644 --- a/lib/Class/Modular.pm +++ b/lib/Class/Modular.pm @@ -1,7 +1,7 @@ # 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 . +# file README and COPYING for more information. +# Copyright 2003,2005 by Don Armstrong . # $Id$ package Class::Modular; @@ -12,9 +12,37 @@ Class::Modular -- Modular class generation superclass =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 @@ -28,109 +56,77 @@ functions. Less generic functions can be included or overridden 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 and true classless OOP, like L. =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 +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 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) = @_; @@ -138,104 +134,98 @@ sub load($$;$) { # 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 to allow L 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 @@ -246,59 +236,66 @@ sub clone { 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 @@ -307,24 +304,33 @@ sub can{ } } -=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 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 @@ -333,20 +339,70 @@ sub handledby{ $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. @@ -358,18 +414,23 @@ disconnected or closed. 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; + } } } } @@ -377,12 +438,6 @@ sub DESTROY{ =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. @@ -392,6 +447,8 @@ must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD $Class::Modular::AUTOLOAD = $AUTOLOAD; goto &Class::Modular::AUTOLOAD; +Failure to do the above will break Class::Modular utterly. + =cut sub AUTOLOAD{ @@ -406,11 +463,11 @@ 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 { @@ -418,13 +475,89 @@ sub AUTOLOAD{ } } +=head2 _init + + $self->_init(@args); + +Stores the arguments used at new so modules that are loaded later can +read them from B + +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 + +=cut