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