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