lib/Class/C3.pm

   1
   2 package Class::C3;
   3
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.01';
   8
   9 use Scalar::Util 'blessed';
  10
  11 my %MRO;
  12
  13 sub import {
  14     my $class = caller();
  15     return if $class eq 'main';
  16     $MRO{$class} = undef;
  17 }
  18
  19 INIT {
  20     no strict 'refs';
  21     foreach my $class (keys %MRO) {
  22         my @MRO = calculateMRO($class);
  23         $MRO{$class} = { MRO => \@MRO };
  24         my %methods;
  25         foreach my $local (@MRO[1 .. $#MRO]) {
  26             foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
  27                 next unless !defined *{"${class}::$method"}{CODE};
  28                 if (!exists $methods{$method}) {
  29                     $methods{$method} = {
  30                         orig => "${local}::$method",
  31                         code => \&{"${local}::$method"}
  32                     };
  33                 }
  34             }
  35         }
  36         $MRO{$class}->{methods} = \%methods;
  37     }
  38     #use Data::Dumper; warn Dumper \%MRO;
  39     foreach my $class (keys %MRO) {
  40         #warn "installing methods (" . (join ", " => keys %{$MRO{$class}->{methods}}) . ") for $class";
  41         foreach my $method (keys %{$MRO{$class}->{methods}}) {
  42             #warn "Installing ${class}::$method using " . $MRO{$class}->{methods}->{$method}->{orig};
  43             *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
  44         }
  45     }
  46 }
  47
  48 sub _merge {
  49     my (@seqs) = @_;
  50     my @res;
  51     while (1) {
  52         # remove all empty seqences
  53         my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
  54         # return the list if we have no more no-empty sequences
  55         return @res if not @nonemptyseqs;
  56         my $cand; # a canidate ..
  57         foreach my $seq (@nonemptyseqs) {
  58             $cand = $seq->[0]; # get the head of the list
  59             my $nothead;
  60             foreach my $sub_seq (@nonemptyseqs) {
  61                 # XXX - this is instead of the python "in"
  62                 my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
  63                 # NOTE:
  64                 # jump out as soon as we find one matching
  65                 # there is no reason not too. However, if
  66                 # we find one, then just remove the '&& last'
  67                 $nothead++ && last if exists $in_tail{$cand};
  68             }
  69             last unless $nothead; # leave the loop with our canidate ...
  70             $cand = undef;        # otherwise, reject it ...
  71         }
  72         die "Inconsistent hierarchy" if not $cand;
  73         push @res => $cand;
  74         # now loop through our non-empties and pop
  75         # off the head if it matches our canidate
  76         foreach my $seq (@nonemptyseqs) {
  77             shift @{$seq} if $seq->[0] eq $cand;
  78         }
  79     }
  80 }
  81
  82 sub calculateMRO {
  83     my ($class) = @_;
  84     no strict 'refs';
  85     return _merge(
  86         [ $class ],                                        # the class we are linearizing
  87         (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses
  88         [ @{"${class}::ISA"} ]                             # a list of all the superclasses
  89     );
  90 }
  91
  92 1;
  93
  94 __END__
  95
  96 =pod
  97
  98 =head1 NAME
  99
 100 Class::C3 - A pragma to use the C3 method resolution order algortihm
 101
 102 =head1 SYNOPSIS
 103
 104     package A;
 105     use Class::C3;
 106     sub hello { 'A::hello' }
 107
 108     package B;
 109     use base 'A';
 110     use Class::C3;
 111
 112     package C;
 113     use base 'A';
 114     use Class::C3;
 115
 116     sub hello { 'C::hello' }
 117
 118     package D;
 119     use base ('B', 'C');
 120     use Class::C3;
 121
 122     # Classic Diamond MI pattern
 123     #    [ A ]
 124     #   /     \
 125     # [ B ]  [ C ]
 126     #   \     /
 127     #    [ D ]
 128
 129     package main;
 130
 131     print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
 132
 133     print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
 134
 135     D->can('hello')->();          # can() also works correctly
 136     UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
 137
 138 =head1 DESCRIPTION
 139
 140 This is currently an experimental pragma to change Perl 5's standard method resolution order
 141 from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution
 142 order.
 143
 144 =head2 What is C3?
 145
 146 C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
 147 inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
 148 and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
 149 Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
 150 default MRO for Parrot objects as well.
 151
 152 =head2 How does C3 work.
 153
 154 C3 works by always preserving local precendence ordering. This essentially means that no class will
 155 appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
 156
 157     [ A ]
 158    /     \
 159  [ B ]  [ C ]
 160    \     /
 161     [ D ]
 162
 163 The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
 164 though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
 165 (D, B, C, A), which does not have this same issue.
 166
 167 This example is fairly trival, for more complex examples and a deeper explaination, see the links in
 168 the L<SEE ALSO> section.
 169
 170 =head2 How does this module work?
 171
 172 This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module
 173 calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from
 174 the symbol tables of each of those classes, and builds a set of method aliases for the correct
 175 dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases
 176 into the local classes symbol table.
 177
 178 The end result is actually classes with pre-cached method dispatch. However, this caching does not
 179 do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
 180 your classes to be effectively closed. See the L<CAVEATS> section for more details.
 181
 182 =head1 FUNCTIONS
 183
 184 =over 4
 185
 186 =item B<calculateMRO ($class)>
 187
 188 Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
 189
 190 =back
 191
 192 =head1 CAVEATS
 193
 194 Let me first say, this is an experimental module, and so it should not be used for anything other
 195 then other experimentation for the time being.
 196
 197 That said, it is the authors intention to make this into a completely usable and production stable
 198 module if possible. Time will tell.
 199
 200 And now, onto the caveats.
 201
 202 =over 4
 203
 204 =item Use of C<SUPER::>.
 205
 206 The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
 207 However, it's use in conjuntion with this module is very much not recommended, and in fact very
 208 discouraged. In the future I plan to support a C<NEXT::> style interface to be used to move to the
 209 next most appropriate method in the MRO.
 210
 211 =item Changing C<@ISA>.
 212
 213 It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
 214 do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
 215 module, and therefor probably won't even show up. I am considering some kind of C<recalculateMRO> function
 216 which can be used to recalculate the MRO on demand at runtime, but that is still off in the future.
 217
 218 =item Adding/deleting methods from class symbol tables.
 219
 220 This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol
 221 tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will
 222 not be reflected in the calculated MRO.
 223
 224 =item Not for use with mod_perl
 225
 226 Since this module utilizes the INIT phase, it cannot be easily used with mod_perl. If this module works out
 227 and proves useful in the I<real world>, I will most likely be supporting mod_perl in some way.
 228
 229 =back
 230
 231 =head1 TODO
 232
 233 =over 4
 234
 235 =item More tests
 236
 237 You can never have enough tests :)
 238
 239 I need to convert the other MRO and class-precendence-list related tests from the Perl6-MetaModel (see link
 240 in L<SEE ALSO>). In addition, I need to add some method checks to these tests as well.
 241
 242 =item call-next-method / NEXT:: / next METHOD
 243
 244 I am contemplating some kind of psudeo-package which can dispatch to the next most relevant method in the
 245 MRO. This should not be too hard to implement when the time comes.
 246
 247 =item recalculateMRO
 248
 249 This being Perl, it would be remiss of me to force people to close thier classes at runtime. So I need to
 250 develop a means for recalculating the MRO for a given class.
 251
 252 =back
 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 AUTHOR
 301
 302 stevan little, E<lt>stevan@iinteractive.comE<gt>
 303
 304 =head1 COPYRIGHT AND LICENSE
 305
 306 Copyright 2005 by Infinity Interactive, Inc.
 307
 308 L<http://www.iinteractive.com>
 309
 310 This library is free software; you can redistribute it and/or modify
 311 it under the same terms as Perl itself.
 312
 313 =cut