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