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