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