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