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