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