From: Stevan Little Date: Tue, 15 Nov 2005 01:48:18 +0000 (+0000) Subject: Class::C3 - 0.05 release X-Git-Tag: 0_05^0 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5d5c86d9474664bced2e5285fdffb07e2613aee5;p=gitmo%2FClass-C3.git Class::C3 - 0.05 release --- diff --git a/ChangeLog b/ChangeLog index 5e76252..03b0434 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,20 @@ Revision history for Perl extension Class::C3. +0.05 - Mon, Nov 14, 2005 + - added caching to next::method, courtesy of quicksilver + and mst over at #dbi-class + - added next::method edge case test + - added next::method & NEXT test + +0.04 - Thurs, Sept 29, 2004 + - changed NEXT::METHOD::foo to next::method + - added more tests as well + +0.03 - Wed, Sept 28, 2005 + - added the NEXT::METHOD psuedo package for method + redispatching along the C3 linearization + - added test for this + 0.02 - Mon, Aug 8, 2005 - code refactoring - many comments added diff --git a/MANIFEST b/MANIFEST index 6820463..0897ad6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -12,6 +12,10 @@ t/04_MRO.t t/05_MRO.t t/10_Inconsistent_hierarchy.t t/20_reinitialize.t +t/30_next_method.t +t/31_next_method_skip.t +t/32_next_method_edge_cases.t +t/33_next_method_used_with_NEXT.t t/pod.t t/pod_coverage.t t/lib/A.pm diff --git a/README b/README index 12bdc45..4941635 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Class::C3 version 0.02 +Class::C3 version 0.05 =========================== INSTALLATION diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm index 385fc1d..1b4ea74 100644 --- a/lib/Class/C3.pm +++ b/lib/Class/C3.pm @@ -6,7 +6,7 @@ use warnings; use Scalar::Util 'blessed'; -our $VERSION = '0.02'; +our $VERSION = '0.05'; # this is our global stash of both # MRO's and method dispatch tables @@ -55,12 +55,14 @@ sub initialize { return unless keys %MRO; _calculate_method_dispatch_tables(); _apply_method_dispatch_tables(); + %next::METHOD_CACHE = (); } sub uninitialize { # why bother if we don't have anything ... return unless keys %MRO; _remove_method_dispatch_tables(); + %next::METHOD_CACHE = (); } sub reinitialize { @@ -179,6 +181,46 @@ sub calculateMRO { ); } +package # hide me from PAUSE + next; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +our $VERSION = '0.03'; + +our %METHOD_CACHE; + +sub method { + my @label = (split '::', (caller(1))[3]); + my $label = pop @label; + my $caller = join '::' => @label; + 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) { + last if (defined ($found = *{$class . '::' . $label}{CODE})); + } + + die "No next::method '$label' found for $self" unless $found; + + $found; + } }; +} + 1; __END__ @@ -316,6 +358,47 @@ operation. =back +=head1 METHOD REDISPATCHING + +It is always useful to be able to re-dispatch your method call to the "next most applicable method". This +module provides a pseudo package along the lines of C or C which will re-dispatch the +method along the C3 linearization. This is best show with an examples. + + # a classic diamond MI pattern ... + + / \ + + \ / + + + package A; + use c3; + sub foo { 'A::foo' } + + package B; + use base 'A'; + use c3; + sub foo { 'B::foo => ' . (shift)->next::method() } + + package B; + use base 'A'; + use c3; + sub foo { 'C::foo => ' . (shift)->next::method() } + + package D; + use base ('B', 'C'); + use c3; + sub foo { 'D::foo => ' . (shift)->next::method() } + + print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo" + +A few things to note. First, we do not require you to add on the method name to the C +call (this is unlike C and C which do require that). This helps to enforce the rule +that you cannot dispatch to a method of a different name (this is how C behaves as well). + +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<@_>. + =head1 CAVEATS Let me first say, this is an experimental module, and so it should not be used for anything other @@ -332,8 +415,8 @@ And now, onto the caveats. The idea of C under multiple inheritence is ambigious, and generally not recomended anyway. However, it's use in conjuntion with this module is very much not recommended, and in fact very -discouraged. In the future I plan to support a C style interface to be used to move to the -next most appropriate method in the MRO. +discouraged. The recommended approach is to instead use the supplied C feature, see +more details on it's usage above. =item Changing C<@ISA>. @@ -360,12 +443,19 @@ C for any changes you make to take effect. You can never have enough tests :) -=item call-next-method / NEXT:: / next METHOD +=back -I am contemplating some kind of psudeo-package which can dispatch to the next most relevant method in the -MRO. This should not be too hard to implement when the time comes. +=head1 CODE COVERAGE -=back +I use B to test the code coverage of my tests, below is the B report on this module's test suite. + + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + File stmt bran cond sub pod time total + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + Class/C3.pm 99.2 93.3 66.7 96.0 100.0 92.8 96.3 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + Total 99.2 93.3 66.7 96.0 100.0 92.8 96.3 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ =head1 SEE ALSO diff --git a/t/30_next_method.t b/t/30_next_method.t new file mode 100644 index 0000000..ab0fa31 --- /dev/null +++ b/t/30_next_method.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 6; + +BEGIN { + use lib 'opt', '../opt', '..'; + use_ok('c3'); + # uncomment this line, and re-run the + # test to see the normal p5 dispatch order + #$Class::C3::TURN_OFF_C3 = 1; +} + +=pod + +This tests the classic diamond inheritence pattern. + + + / \ + + \ / + + +=cut + +{ + package Diamond_A; + use c3; + sub hello { 'Diamond_A::hello' } + sub foo { 'Diamond_A::foo' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use c3; + sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } +} +{ + package Diamond_C; + use c3; + use base 'Diamond_A'; + + sub hello { 'Diamond_C::hello => ' . (shift)->next::method() } + sub foo { 'Diamond_C::foo => ' . (shift)->next::method() } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + use c3; + + sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } +} + +is_deeply( + [ Class::C3::calculateMRO('Diamond_D') ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected'); + +is(Diamond_D->can('hello')->('Diamond_D'), + 'Diamond_C::hello => Diamond_A::hello', + '... can(method) resolved itself as expected'); + +is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'), + 'Diamond_C::hello => Diamond_A::hello', + '... can(method) resolved itself as expected'); + +is(Diamond_D->foo, + 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo', + '... method foo resolved itself as expected'); diff --git a/t/31_next_method_skip.t b/t/31_next_method_skip.t new file mode 100644 index 0000000..eac7cec --- /dev/null +++ b/t/31_next_method_skip.t @@ -0,0 +1,70 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; + +BEGIN { + use lib 'opt', '../opt', '..'; + use_ok('c3'); + # uncomment this line, and re-run the + # test to see the normal p5 dispatch order + #$Class::C3::TURN_OFF_C3 = 1; +} + +=pod + +This tests the classic diamond inheritence pattern. + + + / \ + + \ / + + +=cut + +{ + package Diamond_A; + use c3; + sub bar { 'Diamond_A::bar' } + sub baz { 'Diamond_A::baz' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use c3; + sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } +} +{ + package Diamond_C; + use c3; + use base 'Diamond_A'; + sub foo { 'Diamond_C::foo' } + sub buz { 'Diamond_C::buz' } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + use c3; + 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() } + +} + +is_deeply( + [ Class::C3::calculateMRO('Diamond_D') ], + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly'); +is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly'); +is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly'); +is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly'); +eval { Diamond_D->fuz }; +like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there'); + + diff --git a/t/32_next_method_edge_cases.t b/t/32_next_method_edge_cases.t new file mode 100644 index 0000000..4f85e74 --- /dev/null +++ b/t/32_next_method_edge_cases.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; + +BEGIN { + use_ok('Class::C3'); +} + +{ + + { + package Foo; + use strict; + use warnings; + use Class::C3; + sub new { bless {}, $_[0] } + sub bar { 'Foo::bar' } + } + + # call the submethod in the direct instance + + my $foo = Foo->new(); + isa_ok($foo, 'Foo'); + + can_ok($foo, 'bar'); + is($foo->bar(), 'Foo::bar', '... got the right return value'); + + # fail calling it from a subclass + + { + package Bar; + use strict; + use warnings; + use Class::C3; + our @ISA = ('Foo'); + } + + use Sub::Name; + + my $m = sub { (shift)->next::method() }; + subname('Bar::bar', $m); + { + no strict 'refs'; + *{'Bar::bar'} = $m; + } + + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Foo'); + + can_ok($bar, 'bar'); + my $value = eval { $bar->bar() }; + ok(!$@, '... calling bar() succedded') || diag $@; + is($value, 'Foo::bar', '... got the right return value too'); +} \ No newline at end of file diff --git a/t/33_next_method_used_with_NEXT.t b/t/33_next_method_used_with_NEXT.t new file mode 100644 index 0000000..6547165 --- /dev/null +++ b/t/33_next_method_used_with_NEXT.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { + use_ok('Class::C3'); +} + +{ + package Foo; + use strict; + use warnings; + use Class::C3; + + sub foo { 'Foo::foo' } + + package Fuz; + use strict; + use warnings; + use Class::C3; + use base 'Foo'; + + sub foo { 'Fuz::foo => ' . (shift)->next::method } + + package Bar; + use strict; + use warnings; + use Class::C3; + use base 'Foo'; + + sub foo { 'Bar::foo => ' . (shift)->next::method } + + package Baz; + use strict; + use warnings; + use NEXT; + + use base 'Bar', 'Fuz'; + + sub foo { 'Baz::foo => ' . (shift)->NEXT::foo } +} + +is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo'); +is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo'); +is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo'); + +is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class'); +