From 28a7e8d3cb0ae70d6eab05e526dc786ff837b1af Mon Sep 17 00:00:00 2001 From: Don Armstrong 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 and true classless OOP, like L. =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 - -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 to allow L 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 + +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.2