* Module tests now work correctly

 * Cleaned up Class::Modular documentaiton
 * Stopped improperly using can

git-svn-id: file:///srv/don_svn/class_modular/trunk@20 96c6a18b-02ce-0310-9fca-9eb62c757ba6

diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm
index f66c520e1260836179d58274d21207ad02b39adc..9197583de709999106d6cdc0d5233ed263530492 100644 (file)
--- a/lib/Class/Modular.pm
+++ b/lib/Class/Modular.pm
@@ -1,7 +1,7 @@
-# This file is part of Class::Modular and is released under the terms
-# of the GPL version 2, or any later version at your option. See the
-# file README and COPYING for more information.
-# Copyright 2003, 2004 by Don Armstrong <don@donarmstrong.com>.
+# 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$
 
 package Class::Modular;
 # $Id$
 
 package Class::Modular;


@@ -12,10 +12,19 @@ Class::Modular -- Modular class generation superclass
 
 =head1 SYNOPSIS
 
 
 =head1 SYNOPSIS
 

-     package Foo::Bar;
+     package Foo;

 
      use base qw(Class::Modular);
 
 
      use base qw(Class::Modular);
 

+     [...]
+
+     use Foo;
+
+     $foo = new Foo;
+     $foo->load('Bar');
+     $foo->method_that_bar_provides;
+
+

 =head1 DESCRIPTION
 
 Class::Modular is a superclass for generating modular classes, where
 =head1 DESCRIPTION
 
 Class::Modular is a superclass for generating modular classes, where


@@ -27,10 +36,6 @@ 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.
 

-It fills the middle ground between traditional class based OOP and
-classless OOP. L<Class::Mutator> and L<Sex> are similar to
-Class::Modular but less manic.
-

 =head1 FUNCTIONS
 
 =cut
 =head1 FUNCTIONS
 
 =cut


@@ -48,8 +53,73 @@ BEGIN{
      $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;
 
 our $AUTOLOAD;
 

+=head2 new
+
+=head3 Usage
+
+     $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
+
+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->_init(@args);
+
+     return $self;
+}
+
+
+=head2 _init
+
+=head3 Usage
+
+     $self->_init(@args);
+
+=head3 Function
+
+Stores the arguments used at new so modules that are loaded later can
+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) = @_;
+
+     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
 
 =head3 Usage
 =head2 load
 
 =head3 Usage


@@ -79,35 +149,74 @@ 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 $@;
               eval "require $subclass" or die $@;

-              my @methods = ();
-              if (UNIVERSAL::can($subclass,'METHODS')) {
-                   push @methods,&{"${subclass}::METHODS"};
-              }
-              elsif (UNIVERSAL::can($subclass,'METHODS')) {
-                   push @methods,&{"${subclass}::_methods"};
-              }
-              $self->_addmethods($subclass,@methods);
-              my $initref = UNIVERSAL::can($subclass,'_init');
-              &$initref($self,$options) if defined $initref;
+              $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;
      }
 }
 

-=head2 override
+=head2 _addmethods

 
 =head3 Usage
 
 
 =head3 Usage
 

+     $self->_addmethods()
+
+=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.
+
+=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->{$cm}{_methodhash}->{$method_name}) {
+              if ($self->{$cm}{_methodhash}->{$method_name}->{overridden}) {
+                   carp "Not overriding already overriden method $method_name\n" if $DEBUG;
+                   next;
+              }
+              carp "Overriding $method_name $self->{$cm}{_methodhash}->{$method_name}->{reference} with $method\n";
+         }
+         $self->{$cm}{_methodhash}->{$method_name}->{reference} = $method;
+         $self->{$cm}{_methodhash}->{$method_name}->{subclass} = $subclass;
+     }
+
+}
+
+=head2 override
+
+=head3 Function
+

      $obj->override('methodname', $code_ref)
 
      $obj->override('methodname', $code_ref)
 

+=head3 Returns
+
+TRUE on success, FALSE on failure.
+

 =head3 Function
 
 Allows you to override utility functions that are called internally to
 =head3 Function
 
 Allows you to override utility functions that are called internally to


@@ -125,8 +234,8 @@ may need to be changed.
 sub override {
      my ($self, $method_name, $function_reference) = @_;
 
 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


@@ -142,8 +251,8 @@ 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
 


@@ -154,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} = dclone($self->{_methodhash});
-     $clone->{_subclasses} = dclone($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.
+     $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
+     $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});

 
 

-         # 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';

+              # 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.
               &{"${subclass}::_clone"}($self,$clone);
          };
          if ($@) {
               # Die unless we've hit an undefined subroutine.

-              die $@ unless $@ =~ /Undefined\s*function\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;
+              }

          }
          }

-
-

      }
 }
 
      }
 }
 


@@ -203,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


@@ -241,114 +355,12 @@ 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;
 }
 

-=head1 INTERNAL FUNCTIONS
-
-The functions below are functions internal to Class::Modular. The
-first two, new and _init should probably be overriden in any class
-that inherits from Class::Modular, but they are provided just in case
-you don't want to write a new and/or _init.
-
-=cut
-
-=head2 new
-
-=head3 Usage
-
-     $obj = Foo::Bar->new();
-
-=head3 Function
-
-Creates a new C<Foo::Bar> object.
-
-Aditional arguments can be passed to this creator, and they are stored
-in C<$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->_init(@args);
-
-     return $self;
-}
-
-
-=head2 _init
-
-=head3 Usage
-
-     $self->_init(@args);
-
-=head3 Function
-
-Stores the arguments used at new so modules that are loaded later can
-read them
-
-This function is called by default from new. Classes may only wish to
-override _init.
-
-=cut
-
-sub _init {
-     my ($self,@creation_args) = @_;
-
-     $self->{creation_args} = [@creation_args];
-}
-
-
-=head2 _addmethods
-
-=head3 Usage
-
-     $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
-
-=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.
-
-=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 DESTROY
 
 
 =head2 DESTROY
 


@@ -366,24 +378,30 @@ disconnected or closed.
 
 =cut
 
 
 =cut
 

-
-

 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.
          # use eval to try and call the subclasses _destroy method.
          # Ignore no such function errors, but trap other types of
          # errors.

-         my $destroy_func = UNIVERSAL::can($subclass,'_destroy');
-         &$destroy_func($self) if defined $destroy_func;
+         eval {
+              no strict 'refs';
+              &{"${subclass}::_destroy"}($self);
+         };
+         if ($@) {
+              if ($@ !~ /^Undefined function ${subclass}::_destroy at [^\n]*$/){
+                   die "Failed while trying to destroy: $@";
+              }
+              else {
+                   carp "No _destroy method defined for $subclass" if $DEBUG;
+              }
+         }

      }
 }
 
 
 =head2 AUTOLOAD
 
      }
 }
 
 
 =head2 AUTOLOAD
 

-=head3 Function
-

 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.
 


@@ -407,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 {

diff --git a/t/01_module.t b/t/01_module.t
index e2711c50a5eaca3c594ab39dc8b8c1a0665d7b14..20f4618bdfc5dbd0ff0300fbe5a1faaa6142fa07 100644 (file)
--- a/t/01_module.t
+++ b/t/01_module.t
@@ -23,6 +23,10 @@ my $destroy_hit = 0;
          return 1;
      }
 
          return 1;
      }
 

+     sub _methods {
+          return qw(blah);
+     }
+

      sub _destroy{
          $destroy_hit = 1;
      }
      sub _destroy{
          $destroy_hit = 1;
      }


@@ -36,7 +40,7 @@ ok(defined $foo and ref($foo) eq 'Foo' and UNIVERSAL::isa($foo,'Class::Modular')
 
 $foo->load('Foo');
 # 2: test load()
 
 $foo->load('Foo');
 # 2: test load()

-ok(exists $foo->{_subclasses}{Foo}, 'load() works');
+ok(exists $foo->{__class_modular}{_subclasses}{Foo}, 'load() works');

 # 3: test AUTOLOAD
 ok($foo->blah, 'AUTOLOAD works');
 
 # 3: test AUTOLOAD
 ok($foo->blah, 'AUTOLOAD works');