# 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 <don@donarmstrong.com>.
# $Id: Modular.pm,v 1.6 2003/10/25 03:01:35 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.6 $ =~ /\$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,&{"${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,$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 

=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 (defined $self->{_methodhash}->{$method}->{reference}) {
	  eval {
	       no strict 'refs';
	       goto &$self->{_methodhash}->{$method}->{reference};
	  }
     }
}


1;


__END__






