From cf69259405bc97ddad2947f8a6f33e7921bd4dee Mon Sep 17 00:00:00 2001 From: Don Armstrong Date: Sun, 31 Aug 2003 23:38:55 +0000 Subject: [PATCH] * Initial addition of Modular.pm for Class::Modular. Taken from Da::DB which will be replaced by Da::DBI. git-svn-id: file:///srv/don_svn/class_modular/trunk@1 96c6a18b-02ce-0310-9fca-9eb62c757ba6 --- Class/Modular/Modular.pm | 292 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 292 insertions(+) create mode 100644 Class/Modular/Modular.pm diff --git a/Class/Modular/Modular.pm b/Class/Modular/Modular.pm new file mode 100644 index 0000000..061d927 --- /dev/null +++ b/Class/Modular/Modular.pm @@ -0,0 +1,292 @@ +# 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 2002 by Don +# Armstrong . +# $Id: Modular.pm,v 1.1 2003/08/31 23:38:55 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 BUGS + +None known. + +=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.1 $ =~ /\$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->{_creation_args} = [@args]; + + return $self; +} + + +=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'; + $self->_addmethods($subclass::_methods($self,$options)); + $subclass::_init($self); + }; + warn $@ 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,@methods) = @_; + + # stick the method into the table + # DLA: Make with the munchies! + + foreach my $method (@methods) { + my ($method_name) = $method =~ /\:*([^\:]+)$/; + if ($self->{_methodhash}->{$method_name}->{overridden}) { + carp "Not overriding already overriden method $method_name\n" if $DEBUG; + next; + } + if (exists $self->{_methodhash}->{$method_name}) { + carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n"; + } + $self->{_methodhash}->{$method_name}->{reference} = $method; + } + +} + +=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. + + 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 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. + +=cut + +sub AUTOLOAD{ + my $method = $AUTOLOAD; + + $method =~ s/.*\://; + + my ($self) = @_; + + if (not ref($self)) { + carp "Not a reference in AUTOLOAD."; + return; + } + + if (defined $self->{_methodhash}->{$method}->{reference}) { + eval { + no strict 'refs'; + goto &$self->{_methodhash}->{$method}->{reference}; + } + } +} + + +1; + + +__END__ + + + + + + -- 2.39.2