From: Stevan Little Date: Sun, 7 Aug 2005 18:31:13 +0000 (+0000) Subject: verison 0.01 of Class-C3 X-Git-Tag: 0_05~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FClass-C3.git;a=commitdiff_plain;h=95bebf8c9b18222ddc1363d529f6fd6db46ae50a verison 0.01 of Class-C3 --- diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..cc71f43 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3 @@ +Revision history for Perl extension Class::C3. + +0.01 - \ No newline at end of file diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..5208b57 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,7 @@ +ChangeLog +MANIFEST +README +lib/Class/C3.pm +t/00_load.t +t/01_MRO.t +t/02_MRO.t diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..f62e12e --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,12 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'Class::C3', + 'VERSION_FROM' => 'lib/Class/C3.pm', # finds $VERSION + 'PREREQ_PM' => { + 'Test::More' => 0.47, + 'Test::Exception' => 0.15, + 'Scalar::Util' => 1.10 + } +); diff --git a/README b/README new file mode 100644 index 0000000..3584854 --- /dev/null +++ b/README @@ -0,0 +1,27 @@ +Class::C3 version 0.01 +=========================== + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + None + +COPYRIGHT AND LICENCE + +Copyright (C) 2005 Infinity Interactive, Inc. + +http://www.iinteractive.com + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm new file mode 100644 index 0000000..7e9aa31 --- /dev/null +++ b/lib/Class/C3.pm @@ -0,0 +1,290 @@ + +package Class::C3; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Scalar::Util 'blessed'; + +my %MRO; + +sub import { + my $class = caller(); + return if $class eq 'main'; + $MRO{$class} = undef; +} + +INIT { + no strict 'refs'; + 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; + } + #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 _merge { + my (@seqs) = @_; + my @res; + while (1) { + # remove all empty seqences + my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs); + # return the list if we have no more no-empty sequences + return @res if not @nonemptyseqs; + my $cand; # a canidate .. + foreach my $seq (@nonemptyseqs) { + $cand = $seq->[0]; # get the head of the list + my $nothead; + foreach my $sub_seq (@nonemptyseqs) { + # XXX - this is instead of the python "in" + my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]); + # NOTE: + # jump out as soon as we find one matching + # there is no reason not too. However, if + # we find one, then just remove the '&& last' + $nothead++ && last if exists $in_tail{$cand}; + } + last unless $nothead; # leave the loop with our canidate ... + $cand = undef; # otherwise, reject it ... + } + die "Inconsistent hierarchy" if not $cand; + push @res => $cand; + # now loop through our non-empties and pop + # off the head if it matches our canidate + foreach my $seq (@nonemptyseqs) { + shift @{$seq} if $seq->[0] eq $cand; + } + } +} + +sub calculateMRO { + my ($class) = @_; + no strict 'refs'; + return _merge( + [ $class ], # the class we are linearizing + (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses + [ @{"${class}::ISA"} ] # a list of all the superclasses + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Class::C3 - A pragma to use the C3 method resolution order algortihm + +=head1 SYNOPSIS + + package A; + use Class::C3; + sub hello { 'A::hello' } + + package B; + use base 'A'; + use Class::C3; + + package C; + use base 'A'; + use Class::C3; + + sub hello { 'C::hello' } + + package D; + use base ('B', 'C'); + use Class::C3; + + # Classic Diamond MI pattern + # [ A ] + # / \ + # [ B ] [ C ] + # \ / + # [ D ] + + package main; + + print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A + + print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello' + + D->can('hello')->(); # can() also works correctly + UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can() + +=head1 DESCRIPTION + +This is currently an experimental pragma to change Perl 5's standard method resolution order +from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution +order. + +=head2 What is C3? + +C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple +inheritence. It was first introduced in the langauge Dylan (see links in the L section), +and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in +Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the +default MRO for Parrot objects as well. + +=head2 How does C3 work. + +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 +(D, B, C, A), which does not have this same issue. + +This example is fairly trival, for more complex examples and a deeper explaination, see the links in +the L section. + +=head2 How does this module work? + +This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module +calculates the MRO of all the classes which called C. It then gathers information from +the symbol tables of each of those classes, and builds a set of method aliases for the correct +dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases +into the local classes symbol table. + +The end result is actually classes with pre-cached method dispatch. However, this caching does not +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 FUNCTIONS + +=over 4 + +=item B + +Given a C<$class> this will return an array of class names in the proper C3 method resolution order. + +=back + +=head1 CAVEATS + +Let me first say, this is an experimental module, and so it should not be used for anything other +then other experimentation for the time being. + +That said, it is the authors intention to make this into a completely usable and production stable +module if possible. Time will tell. + +And now, onto the caveats. + +=over 4 + +=item Use of C. + +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. + +=item Changing C<@ISA>. + +It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people +do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this +module, and therefor probably won't even show up. I am considering some kind of C function +which can be used to recalculate the MRO on demand at runtime, but that is still off in the future. + +=item Adding/deleting methods from class symbol tables. + +This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol +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 SEE ALSO + +=head2 The original Dylan paper + +=over 4 + +=item L + +=back + +=head2 The prototype Perl 6 Object Model uses C3 + +=over 4 + +=item L + +=back + +=head2 Parrot now uses C3 + +=over 4 + +=item L + +=item L + +=back + +=head2 Python 2.3 MRO related links + +=over 4 + +=item L + +=item L + +=back + +=head2 C3 for TinyCLOS + +=over 4 + +=item L + +=back + +=head1 AUTHOR + +stevan little, Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2005 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/00_load.t b/t/00_load.t new file mode 100644 index 0000000..9703116 --- /dev/null +++ b/t/00_load.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('Class::C3'); +} \ No newline at end of file diff --git a/t/01_MRO.t b/t/01_MRO.t new file mode 100644 index 0000000..925c3a4 --- /dev/null +++ b/t/01_MRO.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { + use_ok('Class::C3'); +} + +{ + package Diamond_A; + use Class::C3; + sub hello { 'Diamond_A::hello' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use Class::C3; +} +{ + package Diamond_C; + use Class::C3; + use base 'Diamond_A'; + + sub hello { 'Diamond_C::hello' } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + use Class::C3; +} + +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', '... method resolved itself as expected'); +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); + +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); \ No newline at end of file diff --git a/t/02_MRO.t b/t/02_MRO.t new file mode 100644 index 0000000..643cdec --- /dev/null +++ b/t/02_MRO.t @@ -0,0 +1,116 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 15; + +BEGIN { + use_ok('Class::C3'); +} + +=pod + + 6 + --- +Level 3 | O | (more general) + / --- \ + / | \ | + / | \ | + / | \ | + --- --- --- | +Level 2 3 | D | 4| E | | F | 5 | + --- --- --- | + \ \ _ / | | + \ / \ _ | | + \ / \ | | + --- --- | +Level 1 1 | B | | C | 2 | + --- --- | + \ / | + \ / \ / + --- +Level 0 0 | A | (more specialized) + --- + +=cut + +{ + package Test::O; + use Class::C3; + + package Test::F; + use Class::C3; + use base 'Test::O'; + + package Test::E; + use base 'Test::O'; + use Class::C3; + + sub C_or_E { 'Test::E' } + + package Test::D; + use Class::C3; + use base 'Test::O'; + + sub C_or_D { 'Test::D' } + + package Test::C; + use base ('Test::D', 'Test::F'); + use Class::C3; + + sub C_or_D { 'Test::C' } + sub C_or_E { 'Test::C' } + + package Test::B; + use Class::C3; + use base ('Test::D', 'Test::E'); + + package Test::A; + use base ('Test::B', 'Test::C'); + use Class::C3; +} + +is_deeply( + [ Class::C3::calculateMRO('Test::F') ], + [ qw(Test::F Test::O) ], + '... got the right MRO for Test::F'); + +is_deeply( + [ Class::C3::calculateMRO('Test::E') ], + [ qw(Test::E Test::O) ], + '... got the right MRO for Test::E'); + +is_deeply( + [ Class::C3::calculateMRO('Test::D') ], + [ qw(Test::D Test::O) ], + '... got the right MRO for Test::D'); + +is_deeply( + [ Class::C3::calculateMRO('Test::C') ], + [ qw(Test::C Test::D Test::F Test::O) ], + '... got the right MRO for Test::C'); + +is_deeply( + [ Class::C3::calculateMRO('Test::B') ], + [ qw(Test::B Test::D Test::E Test::O) ], + '... got the right MRO for Test::B'); + +is_deeply( + [ Class::C3::calculateMRO('Test::A') ], + [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ], + '... got the right MRO for Test::A'); + +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/pod.t b/t/pod.t new file mode 100644 index 0000000..4ae1af3 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..84632f2 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval "use Test::Pod::Coverage 1.04"; + plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; + + all_pod_coverage_ok({ also_private => [ qr/removeChildAt/ ] }); +} \ No newline at end of file