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
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
-Class::C3 version 0.02
+Class::C3 version 0.05
===========================
INSTALLATION
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
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 {
);
}
+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__
=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<SUPER::> or C<NEXT::> which will re-dispatch the
+method along the C3 linearization. This is best show with an examples.
+
+ # a classic diamond MI pattern ...
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
+
+ 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<next::method>
+call (this is unlike C<NEXT::> and C<SUPER::> 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<NEXT::> behaves as well).
+
+The next thing to keep in mind is that you will need to pass all arguments to C<next::method> 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
The idea of C<SUPER::> 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<NEXT::> 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<next::method> feature, see
+more details on it's usage above.
=item Changing C<@ISA>.
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<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> 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
--- /dev/null
+#!/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.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=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');
--- /dev/null
+#!/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.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=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');
+
+
--- /dev/null
+#!/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
--- /dev/null
+#!/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');
+
projects / gitmo/Class-C3.git / commitdiff