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