From: Stevan Little Date: Wed, 15 Feb 2006 21:16:03 +0000 (+0000) Subject: first commit,.. this is it though not too much here X-Git-Tag: 0_01~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c0b919984a67287b00bf706629417910e58f10bd;p=gitmo%2FAlgorithm-C3.git first commit,.. this is it though not too much here --- diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..b47ec49 --- /dev/null +++ b/Build.PL @@ -0,0 +1,23 @@ +use Module::Build; + +use strict; + +my $build = Module::Build->new( + module_name => 'Algorithm::C3', + license => 'perl', + requires => { + 'Carp' => '0.01', + }, + optional => {}, + build_requires => { + 'Test::More' => '0.47', + }, + create_makefile_pl => 'traditional', + recursive_test_files => 1, + add_to_cleanup => [ + 'META.yml', '*.bak', '*.gz', 'Makefile.PL', + ], +); + +$build->create_build_script; + diff --git a/Changes b/Changes new file mode 100644 index 0000000..4b3e2b5 --- /dev/null +++ b/Changes @@ -0,0 +1,4 @@ +Revision history for Perl extension Algorithm-C3. + +0.01 + - initial release, code taken from Class::C3 \ No newline at end of file diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..a0217f6 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,16 @@ +Build.PL +Makefile.PL +META.yml +Changes +MANIFEST +MANIFEST.SKIP +README +lib/Algorithm/C3.pm +t/000_load.t +t/001_merge.t +t/002_merge.t +t/003_merge.t +t/004_merge.t +t/005_order_disagreement.t +t/pod.t +t/pod_coverage.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..795aeb0 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,18 @@ +^_build +^Build$ +^blib +~$ +\.bak$ +^MANIFEST\.SKIP$ +CVS +\.svn +\.DS_Store +cover_db +\..*\.sw.?$ +^Makefile$ +^pm_to_blib$ +^MakeMaker-\d +^blibdirs$ +\.old$ +^#.*#$ +^\.# \ No newline at end of file diff --git a/README b/README new file mode 100644 index 0000000..07b4b3c --- /dev/null +++ b/README @@ -0,0 +1,29 @@ +Algorithm::C3 version 0.01 +=========================== + +See the individual module documentation for more information + +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) 2006 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/Algorithm/C3.pm b/lib/Algorithm/C3.pm new file mode 100644 index 0000000..5af9182 --- /dev/null +++ b/lib/Algorithm/C3.pm @@ -0,0 +1,255 @@ + +package Algorithm::C3; + +use strict; +use warnings; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +# 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 $class_being_merged = $seqs[0]->[0]; + 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 $reject; + 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 ... + $reject = $cand; + $cand = undef; # otherwise, reject it ... + } + die "Inconsistent hierarchy found while merging '$class_being_merged':\n\t" . + "current merge results [\n\t\t" . (join ",\n\t\t" => @res) . "\n\t]\n\t" . + "mergeing failed on '$reject'\n" 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 merge { + my ($root, $_parent_fetcher) = @_; + my $parent_fetcher = $_parent_fetcher; + unless (ref($parent_fetcher) && ref($parent_fetcher) eq 'CODE') { + $parent_fetcher = $root->can($_parent_fetcher) || confess "Could not find method $_parent_fetcher in $root"; + } + return _merge( + [ $root ], + (map { [ merge($_, $_parent_fetcher) ] } $root->$parent_fetcher()), + [ $parent_fetcher->($root) ], + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Algorithm::C3 - A module for merging lists using the C3 algorithm + +=head1 SYNOPSIS + + use Algorithm::C3; + + # merging a classic diamond + # inheritence graph like this: + # + # + # / \ + # + # \ / + # + + my @merged = Algorithm::C3::merge( + 'D', + sub { + # extract the ISA array + # from the package + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + ); + + print join ", " => @merged; # prints D, B, C, A + +=head1 DESCRIPTION + +This module implements the C3 algorithm. I have broken this out +into it's own module because I found myself copying and pasting +it way too often for various needs. Most of the uses I have for +C3 revolve around class building and metamodels, but it could +also be used for things like dependency resolution as well since +it tends to do such a nice job of preserving local precendence +orderings. + +Below is a brief explanation of C3 taken from the L +module. For more detailed information, see the L section +and the links there. + +=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: + + + / \ + + \ / + + +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. + +=head1 FUNCTION + +=over 4 + +=item B + +This takes a C<$root> node, which can be anything really it +is up to you. Then it takes a C<$func_to_fetch_parent> which +can be either a CODE reference (see L above for an +example), or a string containing a method name to be called +on all the items being linearized. An example of how this +might look is below: + + { + package A; + + sub supers { + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + + package C; + our @ISA = ('A'); + package B; + our @ISA = ('A'); + package D; + our @ISA = ('B', 'C'); + } + + print join ", " => Algorithm::C3::merge('D', 'supers'); + +The purpose of C<$func_to_fetch_parent> is to provide a way +for C to extract the parents of C<$root>. This is +needed for C3 to be able to do it's work. + +=back + +=head1 CODE COVERAGE + +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 + ------------------------ ------ ------ ------ ------ ------ ------ ------ + Algorithm/C3.pm 100.0 100.0 55.6 100.0 100.0 100.0 94.4 + ------------------------ ------ ------ ------ ------ ------ ------ ------ + Total 100.0 100.0 55.6 100.0 100.0 100.0 94.4 + ------------------------ ------ ------ ------ ------ ------ ------ ------ + +=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 2006 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 diff --git a/t/000_load.t b/t/000_load.t new file mode 100644 index 0000000..d2ca3cb --- /dev/null +++ b/t/000_load.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('Algorithm::C3'); +} \ No newline at end of file diff --git a/t/001_merge.t b/t/001_merge.t new file mode 100644 index 0000000..e18f85d --- /dev/null +++ b/t/001_merge.t @@ -0,0 +1,70 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; + +BEGIN { + use_ok('Algorithm::C3'); +} + +{ + package My::A; + package My::C; + our @ISA = ('My::A'); + package My::B; + our @ISA = ('My::A'); + package My::D; + our @ISA = ('My::B', 'My::C'); +} + +{ + my @merged = Algorithm::C3::merge( + 'My::D', + sub { + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + ); + + is_deeply( + \@merged, + [ qw/My::D My::B My::C My::A/ ], + '... merged the lists correctly'); +} + +{ + package My::E; + + sub supers { + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + + package My::F; + our @ISA = ('My::E'); + package My::G; + our @ISA = ('My::E'); + package My::H; + our @ISA = ('My::G', 'My::F'); +} + +{ + my @merged = Algorithm::C3::merge('My::H', 'supers'); + + is_deeply( + \@merged, + [ qw/My::H My::G My::F My::E/ ], + '... merged the lists correctly'); +} + +eval { + Algorithm::C3::merge( + 'My::H', + 'this_method_does_not_exist' + ); +}; +ok($@, '... this died as we expected'); + + diff --git a/t/002_merge.t b/t/002_merge.t new file mode 100644 index 0000000..c27d77b --- /dev/null +++ b/t/002_merge.t @@ -0,0 +1,107 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; + +BEGIN { + use_ok('Algorithm::C3'); +} + +=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) + / --- \ + / | \ | + / | \ | + / | \ | + --- --- --- | +Level 2 3 | D | 4| E | | F | 5 | + --- --- --- | + \ \ _ / | | + \ / \ _ | | + \ / \ | | + --- --- | +Level 1 1 | B | | C | 2 | + --- --- | + \ / | + \ / \ / + --- +Level 0 0 | A | (more specialized) + --- + +=cut + +{ + package Test::O; + + sub supers { + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + + package Test::F; + use base 'Test::O'; + + package Test::E; + use base 'Test::O'; + + package Test::D; + use base 'Test::O'; + + package Test::C; + use base ('Test::D', 'Test::F'); + + package Test::B; + use base ('Test::D', 'Test::E'); + + package Test::A; + use base ('Test::B', 'Test::C'); +} + +is_deeply( + [ Algorithm::C3::merge('Test::F', 'supers') ], + [ qw(Test::F Test::O) ], + '... got the right C3 merge order for Test::F'); + +is_deeply( + [ Algorithm::C3::merge('Test::E', 'supers') ], + [ qw(Test::E Test::O) ], + '... got the right C3 merge order for Test::E'); + +is_deeply( + [ Algorithm::C3::merge('Test::D', 'supers') ], + [ qw(Test::D Test::O) ], + '... got the right C3 merge order for Test::D'); + +is_deeply( + [ Algorithm::C3::merge('Test::C', 'supers') ], + [ qw(Test::C Test::D Test::F Test::O) ], + '... got the right C3 merge order for Test::C'); + +is_deeply( + [ Algorithm::C3::merge('Test::B', 'supers') ], + [ qw(Test::B Test::D Test::E Test::O) ], + '... got the right C3 merge order for Test::B'); + +is_deeply( + [ Algorithm::C3::merge('Test::A', 'supers') ], + [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ], + '... got the right C3 merge order for Test::A'); + + diff --git a/t/003_merge.t b/t/003_merge.t new file mode 100644 index 0000000..8179fa7 --- /dev/null +++ b/t/003_merge.t @@ -0,0 +1,85 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +BEGIN { + use_ok('Algorithm::C3'); +} + +=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; + + sub supers { + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + + package Test::F; + use base 'Test::O'; + + package Test::E; + use base 'Test::O'; + + package Test::D; + use base 'Test::O'; + + package Test::C; + use base ('Test::D', 'Test::F'); + + package Test::B; + use base ('Test::E', 'Test::D'); + + package Test::A; + use base ('Test::B', 'Test::C'); +} + +is_deeply( + [ Algorithm::C3::merge('Test::A', 'supers') ], + [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ], + '... got the right C3 merge order for Test::A'); diff --git a/t/004_merge.t b/t/004_merge.t new file mode 100644 index 0000000..456014c --- /dev/null +++ b/t/004_merge.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +BEGIN { + use_ok('Algorithm::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; + + sub my_ISA { + no strict 'refs'; + @{$_[0] . '::ISA'}; + } + + package LifeForm; + use base 'Object'; + + package Sentient; + use base 'LifeForm'; + + package BiPedal; + use base 'LifeForm'; + + package Intelligent; + use base 'Sentient'; + + package Humanoid; + use base 'BiPedal'; + + package Vulcan; + use base ('Intelligent', 'Humanoid'); +} + +is_deeply( + [ Algorithm::C3::merge('Vulcan', 'my_ISA') ], + [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ], + '... got the right C3 merge order for the Vulcan Dylan Example'); \ No newline at end of file diff --git a/t/005_order_disagreement.t b/t/005_order_disagreement.t new file mode 100644 index 0000000..d02f47a --- /dev/null +++ b/t/005_order_disagreement.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +BEGIN { + use_ok('Algorithm::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; + + package Y; + + package XY; + our @ISA = ('X', 'Y'); + + package YX; + our @ISA = ('Y', 'X'); + + package Z; + our @ISA = ('XY', 'YX'); +} + +eval { + Algorithm::C3::merge('Z' => sub { + no strict 'refs'; + @{$_[0] . '::ISA'}; + }) +}; +like($@, qr/^Inconsistent hierarchy/, '... got the right error with an inconsistent hierarchy'); 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..7569358 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +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();