From: Stevan Little Date: Sat, 1 Jul 2006 20:57:11 +0000 (+0000) Subject: applying patch from Robert Norris for next::can X-Git-Tag: 0.13~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=322a5920b5c506789a9daf817374fd9f0df20ab5;p=gitmo%2FClass-C3.git applying patch from Robert Norris for next::can --- diff --git a/ChangeLog b/ChangeLog index b0c5be6..68cdefb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,9 @@ Revision history for Perl extension Class::C3. 0.12 - clarifying docs for &initialize (thanks jcs) + - applying patch from Robert Norris to add + next::can() functionality which allows safe + probing of the presence of the next method 0.11 Thurs. Feb 23, 2006 - added some more tests for edge cases diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm index bd72a00..a2f4740 100644 --- a/lib/Class/C3.pm +++ b/lib/Class/C3.pm @@ -158,8 +158,8 @@ our $VERSION = '0.05'; our %METHOD_CACHE; -sub method { - my $level = 1; +sub _find { + my $level = 2; my ($method_caller, $label, @label); while ($method_caller = (caller($level++))[3]) { @label = (split '::', $method_caller); @@ -172,28 +172,32 @@ sub method { my $self = $_[0]; my $class = blessed($self) || $self; - goto &{ $METHOD_CACHE{"$class|$caller|$label"} ||= do { - - my @MRO = Class::C3::calculateMRO($class); - - my $current; - while ($current = shift @MRO) { - last if $caller eq $current; - } - - no strict 'refs'; - my $found; - foreach my $class (@MRO) { - next if (defined $Class::C3::MRO{$class} && - defined $Class::C3::MRO{$class}{methods}{$label}); - last if (defined ($found = *{$class . '::' . $label}{CODE})); - } + return $METHOD_CACHE{"$class|$caller|$label"} ||= do { + + my @MRO = Class::C3::calculateMRO($class); + + my $current; + while ($current = shift @MRO) { + last if $caller eq $current; + } + + no strict 'refs'; + my $found; + foreach my $class (@MRO) { + next if (defined $Class::C3::MRO{$class} && + defined $Class::C3::MRO{$class}{methods}{$label}); + last if (defined ($found = *{$class . '::' . $label}{CODE})); + } + + die "No next::method '$label' found for $_[0]" if $_[1] && !$found; + + $found; + }; +} - die "No next::method '$label' found for $self" unless $found; +sub method { goto &{_find($_[0], 1)} } - $found; - } }; -} +sub can { return _find($_[0], 0) ? 1 : 0 } 1; @@ -397,6 +401,12 @@ that you cannot dispatch to a method of a different name (this is how C The next thing to keep in mind is that you will need to pass all arguments to C it can not automatically use the current C<@_>. +If C cannot find a next method to re-dispatch the call to, it will throw an exception. +You can use C to see if C will succeed before you call it like so: + + $self->next::method(@_) if $self->next::can; + + There are some caveats about using C, see below for those. =head1 CAVEATS diff --git a/t/31_next_method_skip.t b/t/31_next_method_skip.t index 26912f0..9bf2a2a 100644 --- a/t/31_next_method_skip.t +++ b/t/31_next_method_skip.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 7; +use Test::More tests => 9; BEGIN { use lib 'opt', '../opt', '..'; @@ -42,7 +42,8 @@ This tests the classic diamond inheritence pattern. use c3; use base 'Diamond_A'; sub foo { 'Diamond_C::foo' } - sub buz { 'Diamond_C::buz' } + sub buz { 'Diamond_C::buz' } + sub woz { 'Diamond_C::woz' } } { package Diamond_D; @@ -51,7 +52,9 @@ This tests the classic diamond inheritence pattern. sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } sub bar { 'Diamond_D::bar => ' . (shift)->next::method() } sub buz { 'Diamond_D::buz => ' . (shift)->baz() } - sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() } + sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() } + sub woz { 'Diamond_D::woz can => ' . (shift)->next::can() } + sub noz { 'Diamond_D::noz can => ' . (shift)->next::can() } } @@ -69,4 +72,5 @@ is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... ca eval { Diamond_D->fuz }; like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there'); - +is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly'); +is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly');