From 7d57528ea18f57f1893e1944dbff1d747ff8d012 Mon Sep 17 00:00:00 2001
From: Don Armstrong <don@donarmstrong.com>
Date: Tue, 29 Jun 2004 10:29:33 +0000
Subject: [PATCH] * 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
---
lib/Class/Modular.pm | 328 +++++++++++++++++++++++--------------------
t/01_module.t | 6 +-
2 files changed, 178 insertions(+), 156 deletions(-)
diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm
index f66c520..9197583 100644
--- 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;
@@ -12,10 +12,19 @@ Class::Modular -- Modular class generation superclass
=head1 SYNOPSIS
- package Foo::Bar;
+ package Foo;
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
@@ -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.
-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
@@ -48,8 +53,73 @@ BEGIN{
$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
+
+=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
@@ -79,35 +149,74 @@ sub load($$;$) {
# 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';
+ # 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 $@;
- 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;
}
}
-=head2 override
+=head2 _addmethods
=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)
+=head3 Returns
+
+TRUE on success, FALSE on failure.
+
=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) = @_;
- $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
@@ -142,8 +251,8 @@ 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.
+Warns if debugging is on for classes which don't have a _clone
+method. Dies on other errors.
=cut
@@ -154,26 +263,29 @@ sub clone {
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';
+ # 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.
- 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) = @_;
- 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.
- return $self->{_methodhash}->{$method}->{reference};
+ return $self->{$cm}{_methodhash}->{$method}->{reference};
}
else {
# Otherwise, let UNIVERSAL::can deal with the method
@@ -241,114 +355,12 @@ sub handledby{
$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;
}
-=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
@@ -366,24 +378,30 @@ disconnected or closed.
=cut
-
-
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.
- 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
-=head3 Function
-
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;
}
- 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';
- goto &{$self->{_methodhash}{$method}{reference}};
+ goto &{$self->{$cm}{_methodhash}{$method}{reference}};
}
}
else {
diff --git a/t/01_module.t b/t/01_module.t
index e2711c5..20f4618 100644
--- a/t/01_module.t
+++ b/t/01_module.t
@@ -23,6 +23,10 @@ my $destroy_hit = 0;
return 1;
}
+ sub _methods {
+ return qw(blah);
+ }
+
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()
-ok(exists $foo->{_subclasses}{Foo}, 'load() works');
+ok(exists $foo->{__class_modular}{_subclasses}{Foo}, 'load() works');
# 3: test AUTOLOAD
ok($foo->blah, 'AUTOLOAD works');
--
2.39.5