X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lib%2FClass%2FModular.pm;h=9197583de709999106d6cdc0d5233ed263530492;hb=7d57528ea18f57f1893e1944dbff1d747ff8d012;hp=5611de9cee97451824d2742def4383303d10e655;hpb=72b5df95c89968c061111bf9063a0e0ef31861f7;p=class_modular.git%2F.git diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm index 5611de9..9197583 100644 --- a/lib/Class/Modular.pm +++ b/lib/Class/Modular.pm @@ -1,7 +1,7 @@ -# This file is part of Class::Modular and is released under the terms -# of the GPL version 2, or any later version at your option. See the -# file README and COPYING for more information. -# Copyright 2003, 2004 by Don Armstrong . +# 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 . # $Id$ package Class::Modular; @@ -12,10 +12,19 @@ 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 Class::Modular is a superclass for generating modular classes, where @@ -27,10 +36,6 @@ 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. -It fills the middle ground between traditional class based OOP and -classless OOP. L and L are similar to -Class::Modular but less manic. - =head1 FUNCTIONS =cut @@ -48,6 +53,11 @@ 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 @@ -58,11 +68,12 @@ our $AUTOLOAD; =head3 Function -Creates a new C object. +Creates a new Foo::Bar object Aditional arguments can be passed to this creator, and they are stored -in C<$self->{_creation_args}>. You can also override the new method in -your subclass. It's just provided here for completeness. +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 @@ -90,14 +101,22 @@ 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; } @@ -130,16 +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 $@; - # Use subclass::METHODS if it exists [use constants METHODS => qw(foo)] $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; @@ -150,7 +171,7 @@ sub load($$;$) { =head3 Usage - $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options)); + $self->_addmethods() =head3 Function @@ -173,25 +194,29 @@ 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 -=head3 Usage +=head3 Function $obj->override('methodname', $code_ref) +=head3 Returns + +TRUE on success, FALSE on failure. + =head3 Function Allows you to override utility functions that are called internally to @@ -209,8 +234,8 @@ may need to be changed. 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 @@ -226,8 +251,8 @@ 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 @@ -238,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; + } } - - } } @@ -287,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 @@ -325,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; } @@ -350,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; + } } } } @@ -369,8 +402,6 @@ sub DESTROY{ =head2 AUTOLOAD -=head3 Function - The AUTOLOAD function is responsible for calling child methods which have been installed into the current Class::Modular handle. @@ -394,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 {