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