X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lib%2FClass%2FModular.pm;h=9197583de709999106d6cdc0d5233ed263530492;hb=7d57528ea18f57f1893e1944dbff1d747ff8d012;hp=1b4a88113e3989007476c4f5f03d52fb14cfb833;hpb=44c8669f46de5293e57a26b841e8ee1f3e51105e;p=class_modular.git%2F.git diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm index 1b4a881..9197583 100644 --- a/lib/Class/Modular.pm +++ b/lib/Class/Modular.pm @@ -12,10 +12,18 @@ Class::Modular -- Modular class generation superclass =head1 SYNOPSIS - package Foo::Bar; + package Foo; use base qw(Class::Modular); + [...] + + use Foo; + + $foo = new Foo; + $foo->load('Bar'); + $foo->method_that_bar_provides; + =head1 DESCRIPTION @@ -45,19 +53,27 @@ BEGIN{ $DEBUG = 0 unless defined $DEBUG; } +# This is the class_modular namespace, so we don't muck up the +# subclass(es) by accident. + +my $cm = q(__class_modular); + our $AUTOLOAD; =head2 new - Title : new - Usage : $obj = Foo::Bar->new(); - Function: Creates a new Foo::Bar object - Returns : A new Foo::Bar object - Args : none. +=head3 Usage - 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. + $obj = Foo::Bar->new(); + +=head3 Function + +Creates a new Foo::Bar object + +Aditional arguments can be passed to this creator, and they are stored +in $self->{creation_args} (and $self->{$cm}{creation_args} by +_init. You can also override the new method in your subclass. It's +just provided here for completeness. =cut @@ -85,35 +101,43 @@ sub new { =head3 Function Stores the arguments used at new so modules that are loaded later can -read them +read them from B + +You can also override this method, but if you do so, you should call +Class::Modular::_init(@_) if you don't set creation_args. =cut sub _init { my ($self,@creation_args) = @_; - $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; } =head2 load - Title : load - Usage : $db->load('FOO::Subclass'); - Function: loads a Class::Modular subclass - Returns : nothing - Args : SCALAR subclass SCALAR options +=head3 Usage + + $db->load('FOO::Subclass'); - Loads the named subclass into this object if the named subclass has - not been loaded. +=head3 Function + +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 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. +The subclasses _init method is called right after methods are loaded. - If debugging is enabled, will warn about loading already loaded - subclasses. +If debugging is enabled, will warn about loading already loaded +subclasses. =cut @@ -125,15 +149,18 @@ 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); }; - die $@ if $@; - $self->{_subclasses}->{$subclass} = {}; + die $@ if $@ and $@ !~ /^Undefined function ${subclass}::_init at [^\n]*$/; + $self->{$cm}{_subclasses}->{$subclass} = {}; } else { carp "Not reloading subclass $subclass" if $DEBUG; @@ -142,17 +169,17 @@ sub load($$;$) { =head2 _addmethods - Title : _addmethods - Usage : $self->_addmethods() - Function: Adds the passed methods into the function table - Returns : - Args : ARRAY of methods +=head3 Usage - Given an array of methods, adds the methods into the _methodhash - calling table. + $self->_addmethods() - Methods that have previously been overridden by override are _NOT_ - overridden again. This may need to be adjusted in load. +=head3 Function + +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 @@ -167,62 +194,65 @@ sub _addmethods($@) { $method = $subclass.'::'.$method; } my ($method_name) = $method =~ /\:*([^\:]+)\s*$/; - if (exists $self->{_methodhash}->{$method_name}) { - if ($self->{_methodhash}->{$method_name}->{overridden}) { + 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->{_methodhash}->{$method_name}->{reference} with $method\n"; + carp "Overriding $method_name $self->{$cm}{_methodhash}->{$method_name}->{reference} with $method\n"; } - $self->{_methodhash}->{$method_name}->{reference} = $method; - $self->{_methodhash}->{$method_name}->{subclass} = $subclass; + $self->{$cm}{_methodhash}->{$method_name}->{reference} = $method; + $self->{$cm}{_methodhash}->{$method_name}->{subclass} = $subclass; } } =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 +=head3 Function - 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. +=head3 Returns - Methods overridden here are _NOT_ overrideable in _addmethods. This - may need to be changed. +TRUE on success, FALSE on failure. + +=head3 Function + +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. =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 : +=head3 Usage - Produces a clone of the object with duplicates of all data and/or new - connections as appropriate. + my $clone = $obj->clone - Calls _clone on all loaded subclasses. +=head3 Function + +Produces a clone of the object with duplicates of all data and/or new +connections as appropriate. + +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. =cut @@ -233,26 +263,29 @@ sub clone { bless $clone, ref($self); # copy data structures at this level - $clone->{_methodhash} = dclone($self->{_methodhash}); - $clone->{_subclasses} = dclone($self->{_subclasses}); + $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash}); + $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_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. - - # 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; + } } - - } } @@ -282,10 +315,12 @@ Scalar Method Name 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 @@ -320,8 +355,8 @@ 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; } @@ -345,18 +380,21 @@ 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); + &{"${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 ${subclass}::_destroy at [^\n]*$/){ + die "Failed while trying to destroy: $@"; + } + else { + carp "No _destroy method defined for $subclass" if $DEBUG; + } } } } @@ -364,12 +402,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. @@ -393,11 +425,11 @@ sub AUTOLOAD{ return; } - if (exists $self->{_methodhash}->{$method} and - defined $self->{_methodhash}->{$method}->{reference}) { + if (exists $self->{$cm}{_methodhash}->{$method} and + defined $self->{$cm}{_methodhash}->{$method}->{reference}) { eval { no strict 'refs'; - goto &{$self->{_methodhash}{$method}{reference}}; + goto &{$self->{$cm}{_methodhash}{$method}{reference}}; } } else {