lib/Algorithm/C3.pm

   1
   2 package Algorithm::C3;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp 'confess';
   8
   9 our $VERSION = '0.06';
  10
  11 sub merge {
  12     my ($root, $parent_fetcher, $cache) = @_;
  13
  14     $cache ||= {};
  15     my @STACK;  # stack for simulating recursion
  16
  17     my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
  18
  19     unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
  20         confess "Could not find method $parent_fetcher in $root";
  21     }
  22
  23     my $current_root = $root;
  24     my $current_parents = [ $root->$parent_fetcher ];
  25     my $recurse_mergeout = [];
  26     my $i = 0;
  27     my %seen;
  28
  29     while(1) {
  30         if($i < @$current_parents) {
  31             my $new_root = $current_parents->[$i++];
  32             die "Infinite loop detected" if $seen{$new_root};
  33             $seen{$new_root} = 1;
  34
  35             unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
  36                 confess "Could not find method $parent_fetcher in $new_root";
  37             }
  38
  39             push(@STACK, [
  40                 $current_root,
  41                 $current_parents,
  42                 $recurse_mergeout,
  43                 $i,
  44             ]);
  45
  46             $current_root = $new_root;
  47             $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
  48             $recurse_mergeout = [];
  49             $i = 0;
  50             next;
  51         }
  52
  53         $seen{$current_root} = 0;
  54
  55         my $mergeout = $cache->{merge}->{$current_root} ||= do {
  56
  57             # This do-block is the code formerly known as the function
  58             # that was a perl-port of the python code at
  59             # http://www.python.org/2.3/mro.html :)
  60
  61             # Initial set (make sure everything is copied - it will be modded)
  62             my @seqs = map { [@$_] } (@$recurse_mergeout, $current_parents);
  63
  64             # Construct the tail-checking hash
  65             my %tails;
  66             foreach my $seq (@seqs) {
  67                 $tails{$_}++ for (@$seq[1..$#$seq]);
  68             }
  69
  70             my @res = ( $current_root );
  71             while (1) {
  72                 my $cand;
  73                 my $winner;
  74                 foreach (@seqs) {
  75                     next if !@$_;
  76                     if(!$winner) {              # looking for a winner
  77                         $cand = $_->[0];        # seq head is candidate
  78                         next if $tails{$cand};  # he loses if in %tails
  79                         push @res => $winner = $cand;
  80                     }
  81                     if($_->[0] eq $winner) {
  82                         shift @$_;                # strip off our winner
  83                         $tails{$_->[0]}-- if @$_; # keep %tails sane
  84                     }
  85                 }
  86                 last if !$cand;
  87                 die q{Inconsistent hierarchy found while merging '}
  88                     . $current_root . qq{':\n\t}
  89                     . qq{current merge results [\n\t\t}
  90                     . (join ",\n\t\t" => @res)
  91                     . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
  92                   if !$winner;
  93             }
  94             \@res;
  95         };
  96
  97         return @$mergeout if !@STACK;
  98
  99         ($current_root, $current_parents, $recurse_mergeout, $i)
 100             = @{pop @STACK};
 101
 102         push(@$recurse_mergeout, $mergeout);
 103     }
 104 }
 105
 106 1;
 107
 108 __END__
 109
 110 =pod
 111
 112 =head1 NAME
 113
 114 Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
 115
 116 =head1 SYNOPSIS
 117
 118   use Algorithm::C3;
 119
 120   # merging a classic diamond
 121   # inheritence graph like this:
 122   #
 123   #    <A>
 124   #   /   \
 125   # <B>   <C>
 126   #   \   /
 127   #    <D>
 128
 129   my @merged = Algorithm::C3::merge(
 130       'D',
 131       sub {
 132           # extract the ISA array
 133           # from the package
 134           no strict 'refs';
 135           @{$_[0] . '::ISA'};
 136       }
 137   );
 138
 139   print join ", " => @merged; # prints D, B, C, A
 140
 141 =head1 DESCRIPTION
 142
 143 This module implements the C3 algorithm. I have broken this out
 144 into it's own module because I found myself copying and pasting
 145 it way too often for various needs. Most of the uses I have for
 146 C3 revolve around class building and metamodels, but it could
 147 also be used for things like dependency resolution as well since
 148 it tends to do such a nice job of preserving local precendence
 149 orderings.
 150
 151 Below is a brief explanation of C3 taken from the L<Class::C3>
 152 module. For more detailed information, see the L<SEE ALSO> section
 153 and the links there.
 154
 155 =head2 What is C3?
 156
 157 C3 is the name of an algorithm which aims to provide a sane method
 158 resolution order under multiple inheritence. It was first introduced
 159 in the langauge Dylan (see links in the L<SEE ALSO> section), and
 160 then later adopted as the prefered MRO (Method Resolution Order)
 161 for the new-style classes in Python 2.3. Most recently it has been
 162 adopted as the 'canonical' MRO for Perl 6 classes, and the default
 163 MRO for Parrot objects as well.
 164
 165 =head2 How does C3 work.
 166
 167 C3 works by always preserving local precendence ordering. This
 168 essentially means that no class will appear before any of it's
 169 subclasses. Take the classic diamond inheritence pattern for
 170 instance:
 171
 172      <A>
 173     /   \
 174   <B>   <C>
 175     \   /
 176      <D>
 177
 178 The standard Perl 5 MRO would be (D, B, A, C). The result being that
 179 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
 180 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
 181 which does not have this same issue.
 182
 183 This example is fairly trival, for more complex examples and a deeper
 184 explaination, see the links in the L<SEE ALSO> section.
 185
 186 =head1 FUNCTION
 187
 188 =over 4
 189
 190 =item B<merge ($root, $func_to_fetch_parent, $cache)>
 191
 192 This takes a C<$root> node, which can be anything really it
 193 is up to you. Then it takes a C<$func_to_fetch_parent> which
 194 can be either a CODE reference (see L<SYNOPSIS> above for an
 195 example), or a string containing a method name to be called
 196 on all the items being linearized. An example of how this
 197 might look is below:
 198
 199   {
 200       package A;
 201
 202       sub supers {
 203           no strict 'refs';
 204           @{$_[0] . '::ISA'};
 205       }
 206
 207       package C;
 208       our @ISA = ('A');
 209       package B;
 210       our @ISA = ('A');
 211       package D;
 212       our @ISA = ('B', 'C');
 213   }
 214
 215   print join ", " => Algorithm::C3::merge('D', 'supers');
 216
 217 The purpose of C<$func_to_fetch_parent> is to provide a way
 218 for C<merge> to extract the parents of C<$root>. This is
 219 needed for C3 to be able to do it's work.
 220
 221 The C<$cache> parameter is an entirely optional performance
 222 measure, and should not change behavior.
 223
 224 If supplied, it should be a hashref that merge can use as a
 225 private cache between runs to speed things up.  Generally
 226 speaking, if you will be calling merge many times on related
 227 things, and the parent fetching function will return constant
 228 results given the same arguments during all of these calls,
 229 you can and should reuse the same shared cache hash for all
 230 of the calls.  Example:
 231
 232   sub do_some_merging {
 233       my %merge_cache;
 234       my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
 235       my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
 236       my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
 237       my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
 238       # ...
 239   }
 240
 241 =back
 242
 243 =head1 CODE COVERAGE
 244
 245 I use B<Devel::Cover> to test the code coverage of my tests, below
 246 is the B<Devel::Cover> report on this module's test suite.
 247
 248  ------------------------ ------ ------ ------ ------ ------ ------ ------
 249  File                       stmt   bran   cond    sub    pod   time  total
 250  ------------------------ ------ ------ ------ ------ ------ ------ ------
 251  Algorithm/C3.pm           100.0  100.0  100.0  100.0  100.0  100.0  100.0
 252  ------------------------ ------ ------ ------ ------ ------ ------ ------
 253  Total                     100.0  100.0  100.0  100.0  100.0  100.0  100.0
 254  ------------------------ ------ ------ ------ ------ ------ ------ ------
 255
 256 =head1 SEE ALSO
 257
 258 =head2 The original Dylan paper
 259
 260 =over 4
 261
 262 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
 263
 264 =back
 265
 266 =head2 The prototype Perl 6 Object Model uses C3
 267
 268 =over 4
 269
 270 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
 271
 272 =back
 273
 274 =head2 Parrot now uses C3
 275
 276 =over 4
 277
 278 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
 279
 280 =item L<http://use.perl.org/~autrijus/journal/25768>
 281
 282 =back
 283
 284 =head2 Python 2.3 MRO related links
 285
 286 =over 4
 287
 288 =item L<http://www.python.org/2.3/mro.html>
 289
 290 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
 291
 292 =back
 293
 294 =head2 C3 for TinyCLOS
 295
 296 =over 4
 297
 298 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
 299
 300 =back
 301
 302 =head1 AUTHORS
 303
 304 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
 305
 306 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 307
 308 =head1 COPYRIGHT AND LICENSE
 309
 310 Copyright 2006 by Infinity Interactive, Inc.
 311
 312 L<http://www.iinteractive.com>
 313
 314 This library is free software; you can redistribute it and/or modify
 315 it under the same terms as Perl itself.
 316
 317 =cut