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