* 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

diff --git a/Class/Modular/Modular.pm b/Class/Modular/Modular.pm
new file mode 100644 (file)
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 <don@donarmstrong.com>.
+# $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__
+
+
+
+
+
+