From: Stevan Little Date: Mon, 8 Aug 2005 02:01:43 +0000 (+0000) Subject: pre-0.02 checkin X-Git-Tag: 0_05~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d401eda1e68a148b69c4e4992de7814fcaa44225;p=gitmo%2FClass-C3.git pre-0.02 checkin --- diff --git a/ChangeLog b/ChangeLog index c9ad846..7838924 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 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 diff --git a/README b/README index 3584854..12bdc45 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Class::C3 version 0.01 +Class::C3 version 0.02 =========================== INSTALLATION diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm index cec9038..3768c47 100644 --- a/lib/Class/C3.pm +++ b/lib/Class/C3.pm @@ -4,47 +4,111 @@ package Class::C3; 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 => [ ], +# methods => { +# orig => , +# code => \& +# } +# } +# 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; @@ -120,11 +184,11 @@ Class::C3 - A pragma to use the C3 method resolution order algortihm use Class::C3; # Classic Diamond MI pattern - # [ A ] - # / \ - # [ B ] [ C ] - # \ / - # [ D ] + # + # / \ + # + # \ / + # package main; @@ -154,11 +218,11 @@ default MRO for Parrot objects as well. 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 ] + + / \ + + \ / + The standard Perl 5 MRO would be (D, B, A, C). The result being that B appears before B, even though B is the subclass of B. The C3 MRO algorithm however, produces the following MRO @@ -179,6 +243,22 @@ The end result is actually classes with pre-cached method dispatch. However, thi 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 section for more details. +=head1 OPTIONAL LOWERCASE PRAGMA + +This release also includes an optional module B in the F 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 @@ -187,6 +267,16 @@ your classes to be effectively closed. See the L section for more detai Given a C<$class> this will return an array of class names in the proper C3 method resolution order. +=item B + +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 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 @@ -221,11 +311,6 @@ This module calculates the MRO for each requested class during the INIT phase by 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, I will most likely be supporting mod_perl in some way. - =back =head1 TODO @@ -299,7 +384,7 @@ develop a means for recalculating the MRO for a given class. =head1 AUTHOR -stevan little, Estevan@iinteractive.comE +Stevan Little, Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE diff --git a/opt/c3.pm b/opt/c3.pm new file mode 100644 index 0000000..91e4764 --- /dev/null +++ b/opt/c3.pm @@ -0,0 +1,23 @@ + +## 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 diff --git a/t/01_MRO.t b/t/01_MRO.t index 925c3a4..40f792f 100644 --- a/t/01_MRO.t +++ b/t/01_MRO.t @@ -7,8 +7,23 @@ 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 tests the classic diamond inheritence pattern. + + + / \ + + \ / + + +=cut + { package Diamond_A; use Class::C3; diff --git a/t/02_MRO.t b/t/02_MRO.t index 643cdec..9008f20 100644 --- a/t/02_MRO.t +++ b/t/02_MRO.t @@ -3,14 +3,29 @@ 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) @@ -104,13 +119,7 @@ is_deeply( 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 diff --git a/t/03_MRO.t b/t/03_MRO.t new file mode 100644 index 0000000..0b098cf --- /dev/null +++ b/t/03_MRO.t @@ -0,0 +1,109 @@ +#!/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() +(, , , +, , , +) + +=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'); diff --git a/t/04_MRO.t b/t/04_MRO.t new file mode 100644 index 0000000..1543a84 --- /dev/null +++ b/t/04_MRO.t @@ -0,0 +1,71 @@ +#!/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 + + Object + ^ + | + LifeForm + ^ ^ + / \ + Sentient BiPedal + ^ ^ + | | + Intelligent Humanoid + ^ ^ + \ / + Vulcan + + define class () end class; + define class () end class; + define class () end class; + define class () end class; + define class (, ) 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 diff --git a/t/05_MRO.t b/t/05_MRO.t new file mode 100644 index 0000000..0591fab --- /dev/null +++ b/t/05_MRO.t @@ -0,0 +1,31 @@ +#!/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'); + diff --git a/t/20_Inconsistent_hierarchy.t b/t/20_Inconsistent_hierarchy.t new file mode 100644 index 0000000..b558146 --- /dev/null +++ b/t/20_Inconsistent_hierarchy.t @@ -0,0 +1,54 @@ +#!/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'); diff --git a/t/lib/A.pm b/t/lib/A.pm new file mode 100644 index 0000000..74acfec --- /dev/null +++ b/t/lib/A.pm @@ -0,0 +1,3 @@ +package t::lib::A; +use c3; +1; \ No newline at end of file diff --git a/t/lib/B.pm b/t/lib/B.pm new file mode 100644 index 0000000..8d5d80f --- /dev/null +++ b/t/lib/B.pm @@ -0,0 +1,3 @@ +package t::lib::B; +use c3; +1; \ No newline at end of file diff --git a/t/lib/C.pm b/t/lib/C.pm new file mode 100644 index 0000000..608ea0c --- /dev/null +++ b/t/lib/C.pm @@ -0,0 +1,4 @@ +package t::lib::C; +use c3; +use base ('t::lib::A', 't::lib::B'); +1; \ No newline at end of file diff --git a/t/lib/D.pm b/t/lib/D.pm new file mode 100644 index 0000000..4ccb3de --- /dev/null +++ b/t/lib/D.pm @@ -0,0 +1,4 @@ +package t::lib::D; +use c3; +use base ('t::lib::A', 't::lib::E'); +1; \ No newline at end of file diff --git a/t/lib/E.pm b/t/lib/E.pm new file mode 100644 index 0000000..4cb7b71 --- /dev/null +++ b/t/lib/E.pm @@ -0,0 +1,3 @@ +package t::lib::E; +use c3; +1; \ No newline at end of file diff --git a/t/lib/F.pm b/t/lib/F.pm new file mode 100644 index 0000000..a53c2d7 --- /dev/null +++ b/t/lib/F.pm @@ -0,0 +1,4 @@ +package t::lib::F; +use c3; +use base ('t::lib::C', 't::lib::D'); +1; \ No newline at end of file