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