Initial Commit
This commit is contained in:
Riley Schneider
338
database/perl/vendor/lib/Algorithm/C3.pm
vendored
Normal file
338
database/perl/vendor/lib/Algorithm/C3.pm
vendored
Normal file
@@ -0,0 +1,338 @@
|
||||
package Algorithm::C3;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp 'confess';
|
||||
|
||||
our $VERSION = '0.11';
|
||||
|
||||
sub merge {
|
||||
my ($root, $parent_fetcher, $cache) = @_;
|
||||
|
||||
$cache ||= {};
|
||||
|
||||
my @STACK; # stack for simulating recursion
|
||||
|
||||
my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
|
||||
|
||||
unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
|
||||
confess "Could not find method $parent_fetcher in $root";
|
||||
}
|
||||
|
||||
my $current_root = $root;
|
||||
my $current_parents = [ $root->$parent_fetcher ];
|
||||
my $recurse_mergeout = [];
|
||||
my $i = 0;
|
||||
my %seen = ( $root => 1 );
|
||||
|
||||
my ($new_root, $mergeout, %tails);
|
||||
while(1) {
|
||||
if($i < @$current_parents) {
|
||||
$new_root = $current_parents->[$i++];
|
||||
|
||||
if($seen{$new_root}) {
|
||||
my @isastack;
|
||||
my $reached;
|
||||
for(my $i = 0; $i < $#STACK; $i += 4) {
|
||||
if($reached || ($reached = ($STACK[$i] eq $new_root))) {
|
||||
push(@isastack, $STACK[$i]);
|
||||
}
|
||||
}
|
||||
my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
|
||||
die "Infinite loop detected in parents of '$root': $isastack";
|
||||
}
|
||||
$seen{$new_root} = 1;
|
||||
|
||||
unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
|
||||
confess "Could not find method $parent_fetcher in $new_root";
|
||||
}
|
||||
|
||||
push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
|
||||
|
||||
$current_root = $new_root;
|
||||
$current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
|
||||
$recurse_mergeout = [];
|
||||
$i = 0;
|
||||
next;
|
||||
}
|
||||
|
||||
$seen{$current_root} = 0;
|
||||
|
||||
$mergeout = $cache->{merge}->{$current_root} ||= do {
|
||||
|
||||
# This do-block is the code formerly known as the function
|
||||
# that was a perl-port of the python code at
|
||||
# http://www.python.org/2.3/mro.html :)
|
||||
|
||||
# Initial set (make sure everything is copied - it will be modded)
|
||||
my @seqs = map { [@$_] } @$recurse_mergeout;
|
||||
push(@seqs, [@$current_parents]) if @$current_parents;
|
||||
|
||||
# Construct the tail-checking hash (actually, it's cheaper and still
|
||||
# correct to re-use it throughout this function)
|
||||
foreach my $seq (@seqs) {
|
||||
$tails{$seq->[$_]}++ for (1..$#$seq);
|
||||
}
|
||||
|
||||
my @res = ( $current_root );
|
||||
while (1) {
|
||||
my $cand;
|
||||
my $winner;
|
||||
foreach (@seqs) {
|
||||
next if !@$_;
|
||||
if(!$winner) { # looking for a winner
|
||||
$cand = $_->[0]; # seq head is candidate
|
||||
next if $tails{$cand}; # he loses if in %tails
|
||||
|
||||
# Handy warn to give a output like the ones on
|
||||
# http://www.python.org/download/releases/2.3/mro/
|
||||
#warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
|
||||
push @res => $winner = $cand;
|
||||
shift @$_; # strip off our winner
|
||||
$tails{$_->[0]}-- if @$_; # keep %tails sane
|
||||
}
|
||||
elsif($_->[0] eq $winner) {
|
||||
shift @$_; # strip off our winner
|
||||
$tails{$_->[0]}-- if @$_; # keep %tails sane
|
||||
}
|
||||
}
|
||||
|
||||
# Handy warn to give a output like the ones on
|
||||
# http://www.python.org/download/releases/2.3/mro/
|
||||
#warn " = " . join(' + ', @res) . "\n" if !$cand;
|
||||
|
||||
last if !$cand;
|
||||
die q{Inconsistent hierarchy found while merging '}
|
||||
. $current_root . qq{':\n\t}
|
||||
. qq{current merge results [\n\t\t}
|
||||
. (join ",\n\t\t" => @res)
|
||||
. qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
|
||||
if !$winner;
|
||||
}
|
||||
\@res;
|
||||
};
|
||||
|
||||
return @$mergeout if !@STACK;
|
||||
|
||||
$i = pop(@STACK);
|
||||
$recurse_mergeout = pop(@STACK);
|
||||
$current_parents = pop(@STACK);
|
||||
$current_root = pop(@STACK);
|
||||
|
||||
push(@$recurse_mergeout, $mergeout);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Algorithm::C3;
|
||||
|
||||
# merging a classic diamond
|
||||
# inheritance graph like this:
|
||||
#
|
||||
# <A>
|
||||
# / \
|
||||
# <B> <C>
|
||||
# \ /
|
||||
# <D>
|
||||
|
||||
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 precedence
|
||||
orderings.
|
||||
|
||||
Below is a brief explanation of C3 taken from the L<Class::C3>
|
||||
module. For more detailed information, see the L<SEE ALSO> 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 inheritance. It was first introduced
|
||||
in the language Dylan (see links in the L<SEE ALSO> section), and
|
||||
then later adopted as the preferred 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 precedence ordering. This
|
||||
essentially means that no class will appear before any of it's
|
||||
subclasses. Take the classic diamond inheritance pattern for
|
||||
instance:
|
||||
|
||||
<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 (D, B, C, A),
|
||||
which does not have this same issue.
|
||||
|
||||
This example is fairly trivial, for more complex examples and a deeper
|
||||
explanation, see the links in the L<SEE ALSO> section.
|
||||
|
||||
=head1 FUNCTION
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<merge ($root, $func_to_fetch_parent, $cache)>
|
||||
|
||||
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<SYNOPSIS> 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<merge> to extract the parents of C<$root>. This is
|
||||
needed for C3 to be able to do it's work.
|
||||
|
||||
The C<$cache> parameter is an entirely optional performance
|
||||
measure, and should not change behavior.
|
||||
|
||||
If supplied, it should be a hashref that merge can use as a
|
||||
private cache between runs to speed things up. Generally
|
||||
speaking, if you will be calling merge many times on related
|
||||
things, and the parent fetching function will return constant
|
||||
results given the same arguments during all of these calls,
|
||||
you can and should reuse the same shared cache hash for all
|
||||
of the calls. Example:
|
||||
|
||||
sub do_some_merging {
|
||||
my %merge_cache;
|
||||
my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
|
||||
my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
|
||||
my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
|
||||
my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
|
||||
# ...
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 CODE COVERAGE
|
||||
|
||||
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
|
||||
------------------------ ------ ------ ------ ------ ------ ------ ------
|
||||
Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
|
||||
------------------------ ------ ------ ------ ------ ------ ------ ------
|
||||
Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
|
||||
------------------------ ------ ------ ------ ------ ------ ------ ------
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=head2 The original Dylan paper
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
|
||||
|
||||
=back
|
||||
|
||||
=head2 The prototype Perl 6 Object Model uses C3
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Parrot now uses C3
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
|
||||
|
||||
=item L<http://use.perl.org/~autrijus/journal/25768>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Python 2.3 MRO related links
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<http://www.python.org/2.3/mro.html>
|
||||
|
||||
=item L<http://www.python.org/2.2.2/descrintro.html#mro>
|
||||
|
||||
=back
|
||||
|
||||
=head2 C3 for TinyCLOS
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
|
||||
|
||||
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2006 by Infinity Interactive, Inc.
|
||||
|
||||
L<http://www.iinteractive.com>
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user