* Module tests now work correctly

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

diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm
index 7977e7e2ca44ccc0a88a6f37913d933bd2a15cf3..9197583de709999106d6cdc0d5233ed263530492 100644 (file)
--- a/lib/Class/Modular.pm
+++ b/lib/Class/Modular.pm
@@ -2,7 +2,7 @@
 # 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>.
 # 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.8 2003/12/09 02:00:10 don Exp $
+# $Id$

 
 package Class::Modular;
 
 
 package Class::Modular;
 


@@ -12,9 +12,17 @@ Class::Modular -- Modular class generation superclass
 
 =head1 SYNOPSIS
 
 
 =head1 SYNOPSIS
 

-package Foo::Bar;
+     package Foo;

 
 

-@ISA = qw(Class::Modular);
+     use base qw(Class::Modular);
+
+     [...]
+
+     use Foo;
+
+     $foo = new Foo;
+     $foo->load('Bar');
+     $foo->method_that_bar_provides;

 
 
 =head1 DESCRIPTION
 
 
 =head1 DESCRIPTION


@@ -28,48 +36,44 @@ 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.
 
 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;
 =head1 FUNCTIONS
 
 =cut
 
 use strict;

-use vars qw($VERSION $DEBUG);
+use vars qw($VERSION $DEBUG $REVISION);

 
 use Carp;
 
 
 use Carp;
 

-use Data::Copy qw(deep_copy); # Used for deep copying objects
+use Storable qw(dclone); # Used for deep copying objects

 
 BEGIN{
 
 BEGIN{

-     ($VERSION) = q$Revision: 1.8 $ =~ /\$Revision:\s+([^\s+])/;
+     $VERSION = '0.1';
+     ($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;

      $DEBUG = 0 unless defined $DEBUG;
 }
 
      $DEBUG = 0 unless defined $DEBUG;
 }
 

+# This is the class_modular namespace, so we don't muck up the
+# subclass(es) by accident.
+
+my $cm = q(__class_modular);
+

 our $AUTOLOAD;
 
 =head2 new
 
 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.
+=head3 Usage

 
 

- 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.
+     $obj = Foo::Bar->new();
+
+=head3 Function
+
+Creates a new Foo::Bar object
+
+Aditional arguments can be passed to this creator, and they are stored
+in $self->{creation_args} (and $self->{$cm}{creation_args} by
+_init. You can also override the new method in your subclass. It's
+just provided here for completeness.

 
 =cut
 
 
 =cut
 


@@ -97,35 +101,43 @@ sub new {
 =head3 Function
 
 Stores the arguments used at new so modules that are loaded later can
 =head3 Function
 
 Stores the arguments used at new so modules that are loaded later can

-read them
+read them from B<creation_args>
+
+You can also override this method, but if you do so, you should call
+Class::Modular::_init(@_) if you don't set creation_args.

 
 =cut
 
 sub _init {
      my ($self,@creation_args) = @_;
 
 
 =cut
 
 sub _init {
      my ($self,@creation_args) = @_;
 

-     $self->{creation_args} = [@_];
+     my $creation_args = [@_];
+     $self->{creation_args} = $creation_args if not exists $self->{creation_args};
+
+     # Make another reference to this, so we can get it if a subclass
+     # overwrites it, or if it was already set for some reason
+     $self->{$cm}->{creation_args} = $creation_args;

 }
 
 
 =head2 load
 
 }
 
 
 =head2 load
 

- Title   : load
- Usage   : $db->load('FOO::Subclass');
- Function: loads a Class::Modular subclass
- Returns : nothing
- Args    : SCALAR subclass SCALAR options
+=head3 Usage
+
+     $db->load('FOO::Subclass');
+
+=head3 Function

 
 

- Loads the named subclass into this object if the named subclass has
- not been loaded.
+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 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.
+The subclasses _init method is called right after methods are loaded.

 
 

- If debugging is enabled, will warn about loading already loaded
- subclasses.
+If debugging is enabled, will warn about loading already loaded
+subclasses.

 
 =cut
 
 
 =cut
 


@@ -137,15 +149,18 @@ sub load($$;$) {
 
      # check to see if the subclass has already been loaded.
 
 
      # check to see if the subclass has already been loaded.
 

-     if (not defined $self->{_subclasses}->{$subclass}){
+     if (not defined $self->{$cm}{_subclasses}->{$subclass}){

          eval {
               no strict 'refs';
          eval {
               no strict 'refs';

+              # Yeah, I don't care if calling an inherited AUTOLOAD
+              # for a non method is deprecated. Bite me.
+              no warnings 'deprecated';

               eval "require $subclass" or die $@;
               $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
               &{"${subclass}::_init"}($self);
          };
               eval "require $subclass" or die $@;
               $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
               &{"${subclass}::_init"}($self);
          };

-         die $@ if $@;
-         $self->{_subclasses}->{$subclass} = {};
+         die $@ if $@ and $@ !~ /^Undefined function ${subclass}::_init at [^\n]*$/;
+         $self->{$cm}{_subclasses}->{$subclass} = {};

      }
      else {
          carp "Not reloading subclass $subclass" if $DEBUG;
      }
      else {
          carp "Not reloading subclass $subclass" if $DEBUG;


@@ -154,17 +169,17 @@ sub load($$;$) {
 
 =head2 _addmethods
 
 
 =head2 _addmethods
 

- Title   : _addmethods
- Usage   : $self->_addmethods()
- Function: Adds the passed methods into the function table
- Returns : 
- Args    : ARRAY of methods
+=head3 Usage
+
+     $self->_addmethods()

 
 

- Given an array of methods, adds the methods into the _methodhash
- calling table.
+=head3 Function
+
+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.
+Methods that have previously been overridden by override are _NOT_
+overridden again. This may need to be adjusted in load.

 
 =cut
 
 
 =cut
 


@@ -179,62 +194,65 @@ sub _addmethods($@) {
               $method = $subclass.'::'.$method;
          }
          my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
               $method = $subclass.'::'.$method;
          }
          my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;

-         if (exists $self->{_methodhash}->{$method_name}) {
-              if ($self->{_methodhash}->{$method_name}->{overridden}) {
+         if (exists $self->{$cm}{_methodhash}->{$method_name}) {
+              if ($self->{$cm}{_methodhash}->{$method_name}->{overridden}) {

                    carp "Not overriding already overriden method $method_name\n" if $DEBUG;
                    next;
               }
                    carp "Not overriding already overriden method $method_name\n" if $DEBUG;
                    next;
               }

-              carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
+              carp "Overriding $method_name $self->{$cm}{_methodhash}->{$method_name}->{reference} with $method\n";

          }
          }

-         $self->{_methodhash}->{$method_name}->{reference} = $method;
-         $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
+         $self->{$cm}{_methodhash}->{$method_name}->{reference} = $method;
+         $self->{$cm}{_methodhash}->{$method_name}->{subclass} = $subclass;

      }
 
 }
 
 =head2 override
 
      }
 
 }
 
 =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
+=head3 Function

 
 

- Allows you to override utility functions that are called internally
- to provide a different default function.
+     $obj->override('methodname', $code_ref)

 
 

- 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.
+=head3 Returns
+
+TRUE on success, FALSE on failure.
+
+=head3 Function

 
 

- Methods overridden here are _NOT_ overrideable in _addmethods. This
- may need to be changed.
+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) = @_;
 
 
 =cut
 
 sub override {
      my ($self, $method_name, $function_reference) = @_;
 

-     $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
-     $self->{_methodhash}->{$method_name}->{overridden} = 1;
+     $self->{$cm}{_methodhash}->{$method_name}->{reference} = $function_reference;
+     $self->{$cm}{_methodhash}->{$method_name}->{overridden} = 1;

 }
 
 =head2 clone
 
 }
 
 =head2 clone
 

- Title   : clone
- Usage   : my $clone  = $obj->clone
- Function: Produces a clone of the Class::Modular object
- Returns : 
- Args    : 
+=head3 Usage
+
+     my $clone  = $obj->clone
+
+=head3 Function

 
 

- Produces a clone of the object with duplicates of all data and/or new
- connections as appropriate.
+Produces a clone of the object with duplicates of all data and/or new
+connections as appropriate.

 
 

- Calls _clone on all loaded subclasses.
+Calls _clone on all loaded subclasses.

 
 

- Warns if debugging is on for classes which don't have a _clone
- method.  Dies on other errors.
+Warns if debugging is on for classes which don't have a _clone
+method.  Dies on other errors.

 
 =cut
 
 
 =cut
 


@@ -245,26 +263,29 @@ sub clone {
      bless $clone, ref($self);
 
      # copy data structures at this level
      bless $clone, ref($self);
 
      # copy data structures at this level

-     $clone->{_methodhash} = deep_copy($self->{_methodhash});
-     $clone->{_subclasses} = deep_copy($self->{_subclasses});
+     $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
+     $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_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.
+     foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
+         # Find out if the subclass has a clone method.
+         # If it does, call it, die on errors.
+         my $function = UNIVERSAL::can($subclass, '_clone');

          eval {
               no strict 'refs';
          eval {
               no strict 'refs';

-              &$subclass::_clone($self,$clone);
+              # No, I could care less that AUTOLOAD is
+              # deprecated. Eat me.
+              no warnings 'deprecated';
+              &{"${subclass}::_clone"}($self,$clone);

          };
          if ($@) {
               # Die unless we've hit an undefined subroutine.
          };
          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;
+              if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){
+                   die "Failed while trying to clone: $@";
+              }
+              else {
+                   carp "No _clone method defined for $subclass" if $DEBUG;
+              }

          }
          }

-
-

      }
 }
 
      }
 }
 


@@ -294,10 +315,12 @@ Scalar Method Name
 sub can{
      my ($self,$method,$vars) = @_;
 
 sub can{
      my ($self,$method,$vars) = @_;
 

-     if (ref $self and exists $self->{_methodhash}->{$method}) {
+     croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method;
+
+     if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) {

          # If the method is defined, return a reference to the
          # method.
          # If the method is defined, return a reference to the
          # method.

-         return $self->{_methodhash}->{$method}->{reference};
+         return $self->{$cm}{_methodhash}->{$method}->{reference};

      }
      else {
          # Otherwise, let UNIVERSAL::can deal with the method
      }
      else {
          # Otherwise, let UNIVERSAL::can deal with the method


@@ -332,8 +355,8 @@ sub handledby{
 
      $method_name =~ s/.*\://;
 
 
      $method_name =~ s/.*\://;
 

-     if (exists $self->{_methodhash}->{$method_name}) {
-         return $self->{_methodhash}->{$method_name}->{subclass};
+     if (exists $self->{$cm}{_methodhash}->{$method_name}) {
+         return $self->{$cm}{_methodhash}->{$method_name}->{subclass};

      }
      return undef;
 }
      }
      return undef;
 }


@@ -357,18 +380,21 @@ disconnected or closed.
 
 sub DESTROY{
      my $self = shift;
 
 sub DESTROY{
      my $self = shift;

-     foreach my $subclass (keys %{$self->{_subclasses}}) {
+     foreach my $subclass (keys %{$self->{$cm}{_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';
          # 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);
+              &{"${subclass}::_destroy"}($self);

          };
          if ($@) {
          };
          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;
+              if ($@ !~ /^Undefined function ${subclass}::_destroy at [^\n]*$/){
+                   die "Failed while trying to destroy: $@";
+              }
+              else {
+                   carp "No _destroy method defined for $subclass" if $DEBUG;
+              }

          }
      }
 }
          }
      }
 }


@@ -376,12 +402,6 @@ sub DESTROY{
 
 =head2 AUTOLOAD
 
 
 =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.
 
 The AUTOLOAD function is responsible for calling child methods which
 have been installed into the current Class::Modular handle.
 


@@ -405,11 +425,11 @@ sub AUTOLOAD{
         return;
      }
 
         return;
      }
 

-     if (exists $self->{_methodhash}->{$method} and
-        defined $self->{_methodhash}->{$method}->{reference}) {
+     if (exists $self->{$cm}{_methodhash}->{$method} and
+        defined $self->{$cm}{_methodhash}->{$method}->{reference}) {

          eval {
               no strict 'refs';
          eval {
               no strict 'refs';

-              goto &{$self->{_methodhash}{$method}{reference}};
+              goto &{$self->{$cm}{_methodhash}{$method}{reference}};

          }
      }
      else {
          }
      }
      else {