From 28a7e8d3cb0ae70d6eab05e526dc786ff837b1af Mon Sep 17 00:00:00 2001
From: Don Armstrong <don@donarmstrong.com>
Date: Sun, 24 Oct 2004 09:29:41 +0000
Subject: [PATCH] === Class::Modular === * Add Safe support and allow
Storable to use Deparse to handle CODE references in clones * Rearange
function order so that the documentation is in a sane order in Class::Modular
* Add USE_SAFE variable to control whether Safe is used * Improve
documentation === t/01_module.t * Enable Override test * Add test for
non-existant _destroy causing failure at DESTROY. [This bug was present in
0.02, and is now fixed.]
git-svn-id: file:///srv/don_svn/class_modular/trunk@31 96c6a18b-02ce-0310-9fca-9eb62c757ba6
---
lib/Class/Modular.pm | 305 +++++++++++++++++++++----------------------
t/01_module.t | 37 +++++-
2 files changed, 182 insertions(+), 160 deletions(-)
diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm
index d833b73..2eb0251 100644
--- a/lib/Class/Modular.pm
+++ b/lib/Class/Modular.pm
@@ -63,16 +63,18 @@ L<Class::Mutator> and true classless OOP, like L<Class::Classless>.
=cut
use strict;
-use vars qw($VERSION $DEBUG $REVISION);
+use vars qw($VERSION $DEBUG $REVISION $USE_SAFE);
use Carp;
use Storable qw(dclone); # Used for deep copying objects
+use Safe; # Use Safe when we are dealing with coderefs
BEGIN{
$VERSION = q$0.03SVN$;
($REVISION) = q$LastChangedRevision$ =~ /\$LastChangedRevision:\s+([^\s+])/;
$DEBUG = 0 unless defined $DEBUG;
+ $USE_SAFE = 1 unless defined $USE_SAFE;
}
# This is the class_modular namespace, so we don't muck up the
@@ -82,74 +84,11 @@ 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($self,@_) 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
-
$db->load('FOO::Subclass');
-=head3 Function
-
Loads the named subclass into this object if the named subclass has
not been loaded.
@@ -163,7 +102,6 @@ subclasses.
=cut
-
sub load($$;$) {
my ($self,$subclass,$options) = @_;
@@ -189,64 +127,15 @@ sub load($$;$) {
}
}
-=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
-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.
+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.
@@ -260,21 +149,22 @@ sub override {
$self->{$cm}{_methodhash}{$method_name}{overridden} = 1;
}
-=head2 clone
-=head3 Usage
+=head2 clone
my $clone = $obj->clone
-=head3 Function
-
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.
+Warns if debugging is on for classes which don't have a _clone method.
+Dies on other errors.
+
+clone uses L<Safe> to allow L<Storable> to deparse code references
+sanely. Set C<$Class::Modular::USE_SAFE = 0> to disable this. [Doing
+this may cause errors from Storable about CODE references.]
=cut
@@ -285,8 +175,18 @@ sub clone {
bless $clone, ref($self);
# copy data structures at this level
- $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
- $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
+ if ($self->{$cm}{use_safe}) {
+ my $safe = new Safe;
+ $safe->permit(qw(:default require));
+ local $Storable::Deparse = 1;
+ local $Storable::Eval = sub { $safe->reval($_[0]) };
+ $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
+ $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
+ }
+ else {
+ $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash});
+ $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses});
+ }
foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) {
# Find out if the subclass has a clone method.
@@ -311,26 +211,18 @@ sub clone {
}
}
-=head2 can
-=head3 Usage
+=head2 can
$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 we don't know
anything it doesn't.
-=head3 Returns
-
-A coderef to the method if the method is supported, undef otherwise.
-
-=head3 Args
-
-Scalar Method Name
+Returns a coderef to the method if the method is supported, undef
+otherwise.
=cut
@@ -351,24 +243,13 @@ sub can{
}
}
-=head2 handledby
-=head3 Usage
+=head2 handledby
$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
+Returns the subclass that handles the method methodname.
=cut
@@ -384,13 +265,63 @@ sub handledby{
}
-=head2 DESTROY
+=head2 new
-=head3 Usage
+ $obj = Foo::Bar->new(qw(baz quux));
-Called by perl.
+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.
+
+This new function creates an object of Class::Modular, and calls the
+C<$self->load(Foo::Bar)>, which will typically do what you want.
+
+If you override this method in your subclasses, you will not be able
+to use override to override methods defined within those
+subclasses. This may or may not be a feature. You must also call
+C<$self->SUPER::_init(@_)> if you override new.
+
+=cut
+
+sub new {
+ my ($class,@args) = @_;
+
+ # We shouldn't be called $me->new, but just in case
+ $class = ref($class) || $class;
+
+ my $self = {};
-=head3 Function
+ # But why, Don, are you being evil and not using the two argument
+ # bless properly?
+
+ # My child, we always want to go to Class::Modular first,
+ # otherwise we will be unable to override methods in subclasses.
+
+ # But doesn't this mean that subclasses won't be able to override
+ # us?
+
+ # Only if they don't also override new!
+
+ bless $self, 'Class::Modular';
+
+ $self->_init(@args);
+
+ # Now we call our subclass's load routine so that our evil deeds
+ # are masked
+
+ $self->load($class);
+
+ return $self;
+}
+
+
+=head1 FUNCTIONS YOU PROBABLY DON'T CARE ABOUT
+
+=head2 DESTROY
+
+ undef $foo;
Calls all subclass _destroy methods.
@@ -408,10 +339,12 @@ sub DESTROY{
# errors.
eval {
no strict 'refs';
+ # Shove off, deprecated AUTOLOAD warning!
+ no warnings 'deprecated';
&{"${subclass}::_destroy"}($self);
};
if ($@) {
- if ($@ !~ /^Undefined subroutine \&${subclass}::_destroy called at [^\n]*$/){
+ if ($@ !~ /^Undefined (function|subroutine) \&?${subclass}::_destroy (|called )at [^\n]*$/){
die "Failed while trying to destroy: $@";
}
else {
@@ -433,6 +366,8 @@ must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
$Class::Modular::AUTOLOAD = $AUTOLOAD;
goto &Class::Modular::AUTOLOAD;
+Failure to do the above will break Class::Modular utterly.
+
=cut
sub AUTOLOAD{
@@ -459,6 +394,68 @@ sub AUTOLOAD{
}
}
+=head2 _init
+
+ $self->_init(@args);
+
+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($self,@_) 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;
+ $self->{$cm}->{use_safe} = $USE_SAFE;
+}
+
+
+=head2 _addmethods
+
+ $self->_addmethods()
+
+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;
+ }
+
+}
+
+
1;
diff --git a/t/01_module.t b/t/01_module.t
index 20f4618..17ce5ec 100644
--- a/t/01_module.t
+++ b/t/01_module.t
@@ -5,14 +5,14 @@
# $Id: $
-use Test::Simple tests => 7;
+use Test::Simple tests => 9;
use UNIVERSAL;
my $destroy_hit = 0;
{
- # Fool require.
+ # Foo require.
$INC{'Foo.pm'} = '1';
package Foo;
@@ -32,21 +32,39 @@ my $destroy_hit = 0;
}
}
+{
+ # Bar require.
+ $INC{'Bar.pm'} = '1';
+ package Bar;
+
+ use base qw(Class::Modular);
+ use constant METHODS => 'bleh';
+
+ sub bleh {
+ return 1;
+ }
+
+ sub _methods {
+ return qw(bleh);
+ }
+}
+
+
+
my $foo = new Foo(qw(bar baz));
# 1: test new
-ok(defined $foo and ref($foo) eq 'Foo' and UNIVERSAL::isa($foo,'Class::Modular'), 'new() works');
+ok(defined $foo and UNIVERSAL::isa($foo,'Class::Modular'), 'new() works');
-$foo->load('Foo');
# 2: test load()
ok(exists $foo->{__class_modular}{_subclasses}{Foo}, 'load() works');
# 3: test AUTOLOAD
ok($foo->blah, 'AUTOLOAD works');
# Check override
-#$foo->override('blah',sub{return 2});
-#ok($foo->blah == 2, 'override() works');
+$foo->override('blah',sub{return 2});
+ok($foo->blah == 2, 'override() works');
# Check can
# 5: Check can
@@ -61,3 +79,10 @@ ok($foo->handledby('blah') eq 'Foo', 'handledby() works');
# Check DESTROY
undef $foo;
ok($destroy_hit,'DESTROY called _destroy');
+
+# Check non-existant _destroy doesn't cause a failure
+
+eval {my $bar = new Bar();
+ undef $bar;
+ };
+ok($@ eq '','Non existant _destroy not a problem');
--
2.39.5