From: Don Armstrong Date: Tue, 9 Dec 2003 02:20:08 +0000 (+0000) Subject: * Moving lib/Modular to lib/Class for MakeMaker X-Git-Url: https://git.donarmstrong.com/?p=class_modular.git%2F.git;a=commitdiff_plain;h=38dd32070977ee6a14487fa384877e431f953285 * Moving lib/Modular to lib/Class for MakeMaker git-svn-id: file:///srv/don_svn/class_modular/trunk@10 96c6a18b-02ce-0310-9fca-9eb62c757ba6 --- diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm new file mode 100644 index 0000000..7977e7e --- /dev/null +++ b/lib/Class/Modular.pm @@ -0,0 +1,430 @@ +# 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: Modular.pm,v 1.8 2003/12/09 02:00:10 don Exp $ + +package Class::Modular; + +=head1 NAME + +Class::Modular -- Modular class generation superclass + +=head1 SYNOPSIS + +package Foo::Bar; + +@ISA = qw(Class::Modular); + + +=head1 DESCRIPTION + +Class::Modular is a superclass for generating modular classes, where +methods can be added into the class from the perspective of the +object, rather than the perspective of the class. + +That is, you can create a class which has a set of generic common +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 + + +=head1 FUNCTIONS + +=cut + +use strict; +use vars qw($VERSION $DEBUG); + +use Carp; + +use Data::Copy qw(deep_copy); # Used for deep copying objects + +BEGIN{ + ($VERSION) = q$Revision: 1.8 $ =~ /\$Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; +} + +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. + + 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. + +=cut + +sub new { + my ($class,@args) = @_; + + # We shouldn't be called $me->new, but just in case + $class = ref($class) || $class; + + my $self = {}; + bless $self, $class; + + $self->_init(@args); + + return $self; +} + + +=head2 _init + +=head3 Usage + + $self->_init(@args); + +=head3 Function + +Stores the arguments used at new so modules that are loaded later can +read them + +=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) = @_; + + $options ||= {}; + + # check to see if the subclass has already been loaded. + + if (not defined $self->{_subclasses}->{$subclass}){ + eval { + no strict 'refs'; + eval "require $subclass" or die $@; + $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options)); + &{"${subclass}::_init"}($self); + }; + die $@ if $@; + $self->{_subclasses}->{$subclass} = {}; + } + else { + carp "Not reloading subclass $subclass" if $DEBUG; + } +} + +=head2 _addmethods + + Title : _addmethods + Usage : $self->_addmethods() + Function: Adds the passed methods into the function table + Returns : + Args : ARRAY of methods + + 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->{_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; + } + +} + +=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. + + 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; +} + +=head2 clone + + Title : clone + Usage : my $clone = $obj->clone + Function: Produces a clone of the Class::Modular object + Returns : + Args : + + 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. + +=cut + +sub clone { + my ($self) = @_; + + my $clone = {}; + bless $clone, ref($self); + + # copy data structures at this level + $clone->{_methodhash} = deep_copy($self->{_methodhash}); + $clone->{_subclasses} = deep_copy($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. + + # XXX Switch to can instead. + eval { + no strict 'refs'; + &$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; + } + + + } +} + +=head2 can + +=head3 Usage + + $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 + +=cut + +sub can{ + my ($self,$method,$vars) = @_; + + if (ref $self and exists $self->{_methodhash}->{$method}) { + # If the method is defined, return a reference to the + # method. + return $self->{_methodhash}->{$method}->{reference}; + } + else { + # Otherwise, let UNIVERSAL::can deal with the method + # appropriately. + return UNIVERSAL::can($self,$method); + } +} + +=head2 handledby + +=head3 Usage + + $obj->handledby('methodname'); + $obj->handledby('Class::Method::methodname'); + +=head3 Function + +Returns the subclass that handles this method. + +=head3 Returns + +SCALAR subclass name + +=head3 Args + +SCALAR method name + +=cut + +sub handledby{ + my ($self,$method_name) = @_; + + $method_name =~ s/.*\://; + + if (exists $self->{_methodhash}->{$method_name}) { + return $self->{_methodhash}->{$method_name}->{subclass}; + } + return undef; +} + + +=head2 DESTROY + +=head3 Usage + +Called by perl. + +=head3 Function + +Calls all subclass _destroy methods. + +Subclasses need only implement a _destroy method if they have +references that need to be uncircularized, or things that should be +disconnected or closed. + +=cut + +sub DESTROY{ + my $self = shift; + foreach my $subclass (keys %{$self->{_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); + }; + 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; + } + } +} + + +=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. + +Subclasses that have a new function as well as an AUTOLOAD function +must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD + + $Class::Modular::AUTOLOAD = $AUTOLOAD; + goto &Class::Modular::AUTOLOAD; + +=cut + +sub AUTOLOAD{ + my $method = $AUTOLOAD; + + $method =~ s/.*\://; + + my ($self) = @_; + + if (not ref($self)) { + carp "Not a reference in AUTOLOAD."; + return; + } + + if (exists $self->{_methodhash}->{$method} and + defined $self->{_methodhash}->{$method}->{reference}) { + eval { + no strict 'refs'; + goto &{$self->{_methodhash}{$method}{reference}}; + } + } + else { + croak "Undefined function $AUTOLOAD"; + } +} + + +1; + + +__END__ + + + + + + diff --git a/lib/Modular/Modular.pm b/lib/Modular/Modular.pm deleted file mode 100644 index 7977e7e..0000000 --- a/lib/Modular/Modular.pm +++ /dev/null @@ -1,430 +0,0 @@ -# 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: Modular.pm,v 1.8 2003/12/09 02:00:10 don Exp $ - -package Class::Modular; - -=head1 NAME - -Class::Modular -- Modular class generation superclass - -=head1 SYNOPSIS - -package Foo::Bar; - -@ISA = qw(Class::Modular); - - -=head1 DESCRIPTION - -Class::Modular is a superclass for generating modular classes, where -methods can be added into the class from the perspective of the -object, rather than the perspective of the class. - -That is, you can create a class which has a set of generic common -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 - - -=head1 FUNCTIONS - -=cut - -use strict; -use vars qw($VERSION $DEBUG); - -use Carp; - -use Data::Copy qw(deep_copy); # Used for deep copying objects - -BEGIN{ - ($VERSION) = q$Revision: 1.8 $ =~ /\$Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; -} - -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. - - 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. - -=cut - -sub new { - my ($class,@args) = @_; - - # We shouldn't be called $me->new, but just in case - $class = ref($class) || $class; - - my $self = {}; - bless $self, $class; - - $self->_init(@args); - - return $self; -} - - -=head2 _init - -=head3 Usage - - $self->_init(@args); - -=head3 Function - -Stores the arguments used at new so modules that are loaded later can -read them - -=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) = @_; - - $options ||= {}; - - # check to see if the subclass has already been loaded. - - if (not defined $self->{_subclasses}->{$subclass}){ - eval { - no strict 'refs'; - eval "require $subclass" or die $@; - $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options)); - &{"${subclass}::_init"}($self); - }; - die $@ if $@; - $self->{_subclasses}->{$subclass} = {}; - } - else { - carp "Not reloading subclass $subclass" if $DEBUG; - } -} - -=head2 _addmethods - - Title : _addmethods - Usage : $self->_addmethods() - Function: Adds the passed methods into the function table - Returns : - Args : ARRAY of methods - - 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->{_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; - } - -} - -=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. - - 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; -} - -=head2 clone - - Title : clone - Usage : my $clone = $obj->clone - Function: Produces a clone of the Class::Modular object - Returns : - Args : - - 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. - -=cut - -sub clone { - my ($self) = @_; - - my $clone = {}; - bless $clone, ref($self); - - # copy data structures at this level - $clone->{_methodhash} = deep_copy($self->{_methodhash}); - $clone->{_subclasses} = deep_copy($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. - - # XXX Switch to can instead. - eval { - no strict 'refs'; - &$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; - } - - - } -} - -=head2 can - -=head3 Usage - - $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 - -=cut - -sub can{ - my ($self,$method,$vars) = @_; - - if (ref $self and exists $self->{_methodhash}->{$method}) { - # If the method is defined, return a reference to the - # method. - return $self->{_methodhash}->{$method}->{reference}; - } - else { - # Otherwise, let UNIVERSAL::can deal with the method - # appropriately. - return UNIVERSAL::can($self,$method); - } -} - -=head2 handledby - -=head3 Usage - - $obj->handledby('methodname'); - $obj->handledby('Class::Method::methodname'); - -=head3 Function - -Returns the subclass that handles this method. - -=head3 Returns - -SCALAR subclass name - -=head3 Args - -SCALAR method name - -=cut - -sub handledby{ - my ($self,$method_name) = @_; - - $method_name =~ s/.*\://; - - if (exists $self->{_methodhash}->{$method_name}) { - return $self->{_methodhash}->{$method_name}->{subclass}; - } - return undef; -} - - -=head2 DESTROY - -=head3 Usage - -Called by perl. - -=head3 Function - -Calls all subclass _destroy methods. - -Subclasses need only implement a _destroy method if they have -references that need to be uncircularized, or things that should be -disconnected or closed. - -=cut - -sub DESTROY{ - my $self = shift; - foreach my $subclass (keys %{$self->{_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); - }; - 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; - } - } -} - - -=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. - -Subclasses that have a new function as well as an AUTOLOAD function -must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD - - $Class::Modular::AUTOLOAD = $AUTOLOAD; - goto &Class::Modular::AUTOLOAD; - -=cut - -sub AUTOLOAD{ - my $method = $AUTOLOAD; - - $method =~ s/.*\://; - - my ($self) = @_; - - if (not ref($self)) { - carp "Not a reference in AUTOLOAD."; - return; - } - - if (exists $self->{_methodhash}->{$method} and - defined $self->{_methodhash}->{$method}->{reference}) { - eval { - no strict 'refs'; - goto &{$self->{_methodhash}{$method}{reference}}; - } - } - else { - croak "Undefined function $AUTOLOAD"; - } -} - - -1; - - -__END__ - - - - - -