* Added handled_by support (returns subclass name)

[class_modular.git/.git] / Class / Modular / Modular.pm

diff --git a/Class/Modular/Modular.pm b/Class/Modular/Modular.pm
index 061d927e688ceed67effd20ff466ac4829dfa22d..c77b7b6bb36d4c2faf4ff74261c333af77408575 100644 (file)
--- a/Class/Modular/Modular.pm
+++ b/Class/Modular/Modular.pm
@@ -1,8 +1,8 @@
 # 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
+# file README and COPYING for more information. Copyright 2003 by Don
 # Armstrong <don@donarmstrong.com>.
-# $Id: Modular.pm,v 1.1 2003/08/31 23:38:55 don Exp $
+# $Id: Modular.pm,v 1.6 2003/10/25 03:01:35 don Exp $
 
 package Class::Modular;
 
@@ -41,9 +41,7 @@ load is responsible for loading database plugins
 =back
 
 
-=head1 BUGS
-
-None known.
+=head1 FUNCTIONS
 
 =cut
 
@@ -55,7 +53,7 @@ use Carp;
 use Data::Copy qw(deep_copy); # Used for deep copying objects
 
 BEGIN{
-     ($VERSION) = q$Revision: 1.1 $ =~ /\$Revision:\s+([^\s+])/;
+     ($VERSION) = q$Revision: 1.6 $ =~ /\$Revision:\s+([^\s+])/;
      $DEBUG = 0 unless defined $DEBUG;
 }
 
@@ -122,8 +120,8 @@ sub load($$;$) {
      if (not defined $self->{_subclasses}->{$subclass}){
          eval {
               no strict 'refs';
-              $self->_addmethods($subclass::_methods($self,$options));
-              $subclass::_init($self);
+              $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
+              &{"${subclass}::_init"}($self);
          };
          warn $@ if $@;
          $self->{_subclasses}->{$subclass} = {};
@@ -150,21 +148,25 @@ sub load($$;$) {
 =cut
 
 sub _addmethods($@) {
-     my ($self,@methods) = @_;
+     my ($self,$subclass,@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 (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;
      }
 
 }
@@ -230,8 +232,9 @@ sub clone {
          # Ignore no such function errors, but trap other types of
          # errors.
 
+         # XXX Switch to can instead.
          eval {
-              no strict refs;
+              no strict 'refs';
               &$subclass::_clone($self,$clone);
          };
          if ($@) {
@@ -244,6 +247,109 @@ sub clone {
      }
 }
 
+=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
@@ -254,8 +360,14 @@ sub clone {
  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.
+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