Revision history for Perl extension Class::C3.
+0.02 - Sun, Aug 7, 2005
+ - code refactoring and comments added
+
0.01 - Sun, Aug 7, 2005
- initial release of module
- some code and test based on previous Perl6::MetaModel work
\ No newline at end of file
-Class::C3 version 0.01
+Class::C3 version 0.02
===========================
INSTALLATION
use strict;
use warnings;
-our $VERSION = '0.01';
-
use Scalar::Util 'blessed';
+our $VERSION = '0.02';
+
+# this is our global stash of both
+# MRO's and method dispatch tables
+# the structure basically looks like
+# this:
+#
+# $MRO{$class} = {
+# MRO => [ <class precendence list> ],
+# methods => {
+# orig => <original location of method>,
+# code => \&<ref to original method>
+# }
+# }
+#
my %MRO;
+# use this for debugging ...
+sub _dump_MRO_table { %MRO }
+
+our $TURN_OFF_C3 = 0;
+
sub import {
my $class = caller();
+ # skip if the caller is main::
+ # since that is clearly not relevant
return if $class eq 'main';
+ return if $TURN_OFF_C3;
+ # make a note to calculate $class
+ # during INIT phase
$MRO{$class} = undef;
}
-INIT {
- no strict 'refs';
+## initializers
+
+# NOTE:
+# this will not run under the following
+# conditions:
+# - mod_perl
+# - require Class::C3;
+# - eval "use Class::C3"
+# in all those cases, you need to call
+# the initialize() function manually
+INIT { initialize() }
+
+sub initialize {
+ # why bother if we don't have anything ...
+ return unless keys %MRO;
+ _calculate_method_dispatch_tables();
+ _apply_method_dispatch_tables();
+}
+
+## functions for applying C3 to classes
+
+sub _calculate_method_dispatch_tables {
foreach my $class (keys %MRO) {
- my @MRO = calculateMRO($class);
- $MRO{$class} = { MRO => \@MRO };
- my %methods;
- foreach my $local (@MRO[1 .. $#MRO]) {
- foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
- next unless !defined *{"${class}::$method"}{CODE};
- if (!exists $methods{$method}) {
- $methods{$method} = {
- orig => "${local}::$method",
- code => \&{"${local}::$method"}
- };
- }
- }
- }
- $MRO{$class}->{methods} = \%methods;
+ _calculate_method_dispatch_table($class);
}
- #use Data::Dumper; warn Dumper \%MRO;
- foreach my $class (keys %MRO) {
- #warn "installing methods (" . (join ", " => keys %{$MRO{$class}->{methods}}) . ") for $class";
- foreach my $method (keys %{$MRO{$class}->{methods}}) {
- #warn "Installing ${class}::$method using " . $MRO{$class}->{methods}->{$method}->{orig};
- *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
+}
+
+sub _calculate_method_dispatch_table {
+ my $class = shift;
+ no strict 'refs';
+ my @MRO = calculateMRO($class);
+ $MRO{$class} = { MRO => \@MRO };
+ my %methods;
+ # NOTE:
+ # we do @MRO[1 .. $#MRO] here because it
+ # makes no sense to interogate the class
+ # which you are calculating for.
+ foreach my $local (@MRO[1 .. $#MRO]) {
+ foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
+ # skip if already overriden in local class
+ next unless !defined *{"${class}::$method"}{CODE};
+ $methods{$method} = {
+ orig => "${local}::$method",
+ code => \&{"${local}::$method"}
+ } unless exists $methods{$method};
}
- }
+ }
+ # now stash them in our %MRO table
+ $MRO{$class}->{methods} = \%methods;
+}
+
+sub _apply_method_dispatch_tables {
+ foreach my $class (keys %MRO) {
+ _apply_method_dispatch_table($class);
+ }
}
+sub _apply_method_dispatch_table {
+ my $class = shift;
+ no strict 'refs';
+ foreach my $method (keys %{$MRO{$class}->{methods}}) {
+ *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
+ }
+}
+
+## functions for calculating C3 MRO
+
+# this function is a perl-port of the
+# python code on this page:
+# http://www.python.org/2.3/mro.html
sub _merge {
my (@seqs) = @_;
my @res;
use Class::C3;
# Classic Diamond MI pattern
- # [ A ]
- # / \
- # [ B ] [ C ]
- # \ /
- # [ D ]
+ # <A>
+ # / \
+ # <B> <C>
+ # \ /
+ # <D>
package main;
C3 works by always preserving local precendence ordering. This essentially means that no class will
appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
- [ A ]
- / \
- [ B ] [ C ]
- \ /
- [ D ]
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
your classes to be effectively closed. See the L<CAVEATS> section for more details.
+=head1 OPTIONAL LOWERCASE PRAGMA
+
+This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
+the regular install since lowercase module names are considered I<"bad"> by some people. However I
+think that code looks much nicer like this:
+
+ package MyClass;
+ use c3;
+
+The the more clunky:
+
+ package MyClass;
+ use Class::C3;
+
+But hey, it's your choice, thats why it is optional.
+
=head1 FUNCTIONS
=over 4
Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
+=item B<initialize>
+
+This can be used to initalize the C3 method dispatch tables. You need to call this if you are running
+under mod_perl, or in any other environment which does not run the INIT phase of the perl compiler.
+
+NOTE:
+This can B<not> be used to re-load the dispatch tables for all classes. This is because it does not first
+return the classes to their virginal state, which would need to happen in order for the dispatch tables
+to be properly reloaded.
+
=back
=head1 CAVEATS
tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will
not be reflected in the calculated MRO.
-=item Not for use with mod_perl
-
-Since this module utilizes the INIT phase, it cannot be easily used with mod_perl. If this module works out
-and proves useful in the I<real world>, I will most likely be supporting mod_perl in some way.
-
=back
=head1 TODO
=head1 AUTHOR
-stevan little, E<lt>stevan@iinteractive.comE<gt>
+Stevan Little, E<lt>stevan@iinteractive.comE<gt>
=head1 COPYRIGHT AND LICENSE
--- /dev/null
+
+## OPTIONAL MODULE
+# this module is supplied simply the use of this module
+# more aesthetically pleasing (at least to me), I think
+# it is much nicer to see:
+#
+# use c3;
+#
+# then to see a bunch of:
+#
+# use Class::C3;
+#
+# all over the place.
+
+package # ignore me PAUSE
+ c3;
+
+BEGIN {
+ use Class::C3;
+ *{'c3::'} = *{'Class::C3::'};
+}
+
+1;
\ No newline at end of file
BEGIN {
use_ok('Class::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 Class::C3;
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 11;
BEGIN {
use_ok('Class::C3');
+ # uncomment this line, and re-run the
+ # test to see the normal p5 dispatch order
+ #$Class::C3::TURN_OFF_C3 = 1;
}
=pod
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
6
---
Level 3 | O | (more general)
is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
-is(Test::B->C_or_D, 'Test::D', '... got the expected method output');
-is(Test::B->can('C_or_D')->(), 'Test::D', '... can got the expected method output');
-
is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
-is(Test::B->C_or_E, 'Test::E', '... got the expected method output');
-is(Test::B->can('C_or_E')->(), 'Test::E', '... can got the expected method output');
-
\ 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');
+ # uncomment this line, and re-run the
+ # test to see the normal p5 dispatch order
+ #$Class::C3::TURN_OFF_C3 = 1;
+}
+
+=pod
+
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package Test::O;
+ use Class::C3;
+
+ sub O_or_D { 'Test::O' }
+ sub O_or_F { 'Test::O' }
+
+ package Test::F;
+ use base 'Test::O';
+ use Class::C3;
+
+ sub O_or_F { 'Test::F' }
+
+ package Test::E;
+ use base 'Test::O';
+ use Class::C3;
+
+ package Test::D;
+ use base 'Test::O';
+ use Class::C3;
+
+ sub O_or_D { 'Test::D' }
+ sub C_or_D { 'Test::D' }
+
+ package Test::C;
+ use base ('Test::D', 'Test::F');
+ use Class::C3;
+
+ sub C_or_D { 'Test::C' }
+
+ package Test::B;
+ use base ('Test::E', 'Test::D');
+ use Class::C3;
+
+ package Test::A;
+ use base ('Test::B', 'Test::C');
+ use Class::C3;
+}
+
+is_deeply(
+ [ Class::C3::calculateMRO('Test::A') ],
+ [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
+ '... got the right MRO for Test::A');
+
+is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
+is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call Test::D before Test::C and Test::D is a
+# subclass of Test::C
+is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+BEGIN {
+ use lib 'opt', '../opt', '..';
+ use_ok('c3');
+}
+
+=pod
+
+example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
+
+ Object
+ ^
+ |
+ LifeForm
+ ^ ^
+ / \
+ Sentient BiPedal
+ ^ ^
+ | |
+ Intelligent Humanoid
+ ^ ^
+ \ /
+ Vulcan
+
+ define class <sentient> (<life-form>) end class;
+ define class <bipedal> (<life-form>) end class;
+ define class <intelligent> (<sentient>) end class;
+ define class <humanoid> (<bipedal>) end class;
+ define class <vulcan> (<intelligent>, <humanoid>) end class;
+
+=cut
+
+{
+ package Object;
+ use c3;
+
+ package LifeForm;
+ use c3;
+ use base 'Object';
+
+ package Sentient;
+ use c3;
+ use base 'LifeForm';
+
+ package BiPedal;
+ use c3;
+ use base 'LifeForm';
+
+ package Intelligent;
+ use c3;
+ use base 'Sentient';
+
+ package Humanoid;
+ use c3;
+ use base 'BiPedal';
+
+ package Vulcan;
+ use c3;
+ use base ('Intelligent', 'Humanoid');
+}
+
+is_deeply(
+ [ c3::calculateMRO('Vulcan') ],
+ [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
+ '... got the right MRO for the Vulcan Dylan Example');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN {
+ use lib 'opt', '../opt', '..';
+ use_ok('c3');
+ use_ok('t::lib::F');
+}
+
+=pod
+
+From the parrot test t/pmc/object-meths.t
+
+ A B A E
+ \ / \ /
+ C D
+ \ /
+ \ /
+ F
+
+=cut
+
+is_deeply(
+ [ c3::calculateMRO('t::lib::F') ],
+ [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
+ '... got the right MRO for t::lib::F');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+BEGIN {
+ use_ok('Class::C3');
+}
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"Serious order disagreement" # From Guido
+class O: pass
+class X(O): pass
+class Y(O): pass
+class A(X,Y): pass
+class B(Y,X): pass
+try:
+ class Z(A,B): pass #creates Z(A,B) in Python 2.2
+except TypeError:
+ pass # Z(A,B) cannot be created in Python 2.3
+
+=cut
+
+{
+ package X;
+ use Class::C3;
+
+ package Y;
+ use Class::C3;
+
+ package XY;
+ use Class::C3;
+ use base ('X', 'Y');
+
+ package YX;
+ use Class::C3;
+ use base ('Y', 'X');
+
+ package Z;
+ # use Class::C3; << Dont do this just yet ...
+ use base ('XY', 'YX');
+}
+
+eval {
+ # now try to calculate the MRO
+ # and watch it explode :)
+ Class::C3::calculateMRO('Z')
+};
+like($@, qr/^Inconsistent hierarchy/, '... got the right error with an inconsistent hierarchy');
--- /dev/null
+package t::lib::A;
+use c3;
+1;
\ No newline at end of file
--- /dev/null
+package t::lib::B;
+use c3;
+1;
\ No newline at end of file
--- /dev/null
+package t::lib::C;
+use c3;
+use base ('t::lib::A', 't::lib::B');
+1;
\ No newline at end of file
--- /dev/null
+package t::lib::D;
+use c3;
+use base ('t::lib::A', 't::lib::E');
+1;
\ No newline at end of file
--- /dev/null
+package t::lib::E;
+use c3;
+1;
\ No newline at end of file
--- /dev/null
+package t::lib::F;
+use c3;
+use base ('t::lib::C', 't::lib::D');
+1;
\ No newline at end of file
projects / gitmo/Class-C3.git / commitdiff