X-Git-Url: https://git.donarmstrong.com/?p=class_modular.git%2F.git;a=blobdiff_plain;f=lib%2FModular%2FModular.pm;fp=lib%2FModular%2FModular.pm;h=7977e7e2ca44ccc0a88a6f37913d933bd2a15cf3;hp=0000000000000000000000000000000000000000;hb=e247df89b79cd0bd4b73af01e8702cf3799b3237;hpb=222afc29e8aa8af0b4e8a4caf37debb0aee5be84 diff --git a/lib/Modular/Modular.pm b/lib/Modular/Modular.pm new file mode 100644 index 0000000..7977e7e --- /dev/null +++ b/lib/Modular/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__ + + + + + +