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