lib/Class/C3.pm

   1
   2 package Class::C3;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'blessed';
   8
   9 our $VERSION = '0.06';
  10
  11 # this is our global stash of both
  12 # MRO's and method dispatch tables
  13 # the structure basically looks like
  14 # this:
  15 #
  16 #   $MRO{$class} = {
  17 #      MRO => [ <class precendence list> ],
  18 #      methods => {
  19 #          orig => <original location of method>,
  20 #          code => \&<ref to original method>
  21 #      }
  22 #   }
  23 #
  24 my %MRO;
  25
  26 # use these for debugging ...
  27 sub _dump_MRO_table { %MRO }
  28 our $TURN_OFF_C3 = 0;
  29
  30 sub import {
  31     my $class = caller();
  32     # skip if the caller is main::
  33     # since that is clearly not relevant
  34     return if $class eq 'main';
  35     return if $TURN_OFF_C3;
  36     # make a note to calculate $class
  37     # during INIT phase
  38     $MRO{$class} = undef;
  39 }
  40
  41 ## initializers
  42
  43 # NOTE:
  44 # this will not run under the following
  45 # conditions:
  46 #  - mod_perl
  47 #  - require Class::C3;
  48 #  - eval "use Class::C3"
  49 # in all those cases, you need to call
  50 # the initialize() function manually
  51 INIT { initialize() }
  52
  53 sub initialize {
  54     # why bother if we don't have anything ...
  55     return unless keys %MRO;
  56     _calculate_method_dispatch_tables();
  57     _apply_method_dispatch_tables();
  58     %next::METHOD_CACHE = ();
  59 }
  60
  61 sub uninitialize {
  62     # why bother if we don't have anything ...
  63     return unless keys %MRO;
  64     _remove_method_dispatch_tables();
  65     %next::METHOD_CACHE = ();
  66 }
  67
  68 sub reinitialize {
  69     uninitialize();
  70     # clean up the %MRO before we re-initialize
  71     $MRO{$_} = undef foreach keys %MRO;
  72     initialize();
  73 }
  74
  75 ## functions for applying C3 to classes
  76
  77 sub _calculate_method_dispatch_tables {
  78     foreach my $class (keys %MRO) {
  79         _calculate_method_dispatch_table($class);
  80     }
  81 }
  82
  83 sub _calculate_method_dispatch_table {
  84     my $class = shift;
  85     no strict 'refs';
  86     my @MRO = calculateMRO($class);
  87     $MRO{$class} = { MRO => \@MRO };
  88     my %methods;
  89     # NOTE:
  90     # we do @MRO[1 .. $#MRO] here because it
  91     # makes no sense to interogate the class
  92     # which you are calculating for.
  93     foreach my $local (@MRO[1 .. $#MRO]) {
  94         foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
  95             # skip if already overriden in local class
  96             next unless !defined *{"${class}::$method"}{CODE};
  97             $methods{$method} = {
  98                 orig => "${local}::$method",
  99                 code => \&{"${local}::$method"}
 100             } unless exists $methods{$method};
 101         }
 102     }
 103     # now stash them in our %MRO table
 104     $MRO{$class}->{methods} = \%methods;
 105 }
 106
 107 sub _apply_method_dispatch_tables {
 108     foreach my $class (keys %MRO) {
 109         _apply_method_dispatch_table($class);
 110     }
 111 }
 112
 113 sub _apply_method_dispatch_table {
 114     my $class = shift;
 115     no strict 'refs';
 116     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 117         *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
 118     }
 119 }
 120
 121 sub _remove_method_dispatch_tables {
 122     foreach my $class (keys %MRO) {
 123         _remove_method_dispatch_table($class);
 124     }
 125 }
 126
 127 sub _remove_method_dispatch_table {
 128     my $class = shift;
 129     no strict 'refs';
 130     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 131         delete ${"${class}::"}{$method};
 132     }
 133 }
 134
 135 ## functions for calculating C3 MRO
 136
 137 # this function is a perl-port of the
 138 # python code on this page:
 139 #   http://www.python.org/2.3/mro.html
 140 sub _merge {
 141     my (@seqs) = @_;
 142     my $class_being_merged = $seqs[0]->[0];
 143     my @res;
 144     while (1) {
 145         # remove all empty seqences
 146         my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
 147         # return the list if we have no more no-empty sequences
 148         return @res if not @nonemptyseqs;
 149         my $reject;
 150         my $cand; # a canidate ..
 151         foreach my $seq (@nonemptyseqs) {
 152             $cand = $seq->[0]; # get the head of the list
 153             my $nothead;
 154             foreach my $sub_seq (@nonemptyseqs) {
 155                 # XXX - this is instead of the python "in"
 156                 my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
 157                 # NOTE:
 158                 # jump out as soon as we find one matching
 159                 # there is no reason not too. However, if
 160                 # we find one, then just remove the '&& last'
 161                 $nothead++ && last if exists $in_tail{$cand};
 162             }
 163             last unless $nothead; # leave the loop with our canidate ...
 164             $reject = $cand;
 165             $cand = undef;        # otherwise, reject it ...
 166         }
 167         die "Inconsistent hierarchy found while merging '$class_being_merged':\n\t" .
 168             "current merge results [\n\t\t" . (join ",\n\t\t" => @res) . "\n\t]\n\t" .
 169             "mergeing failed on '$reject'\n" if not $cand;
 170         push @res => $cand;
 171         # now loop through our non-empties and pop
 172         # off the head if it matches our canidate
 173         foreach my $seq (@nonemptyseqs) {
 174             shift @{$seq} if $seq->[0] eq $cand;
 175         }
 176     }
 177 }
 178
 179 sub calculateMRO {
 180     my ($class) = @_;
 181     no strict 'refs';
 182     return _merge(
 183         [ $class ],                                        # the class we are linearizing
 184         (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses
 185         [ @{"${class}::ISA"} ]                             # a list of all the superclasses
 186     );
 187 }
 188
 189 package  # hide me from PAUSE
 190     next;
 191
 192 use strict;
 193 use warnings;
 194
 195 use Scalar::Util 'blessed';
 196
 197 our $VERSION = '0.03';
 198
 199 our %METHOD_CACHE;
 200
 201 sub method {
 202     my @label    = (split '::', (caller(1))[3]);
 203     my $label    = pop @label;
 204     my $caller   = join '::' => @label;
 205     my $self     = $_[0];
 206     my $class    = blessed($self) || $self;
 207
 208     goto &{ $METHOD_CACHE{"$class|$caller|$label"} ||= do {
 209
 210       my @MRO = Class::C3::calculateMRO($class);
 211
 212       my $current;
 213       while ($current = shift @MRO) {
 214           last if $caller eq $current;
 215       }
 216
 217       no strict 'refs';
 218       my $found;
 219       foreach my $class (@MRO) {
 220           last if (defined ($found = *{$class . '::' . $label}{CODE}));
 221       }
 222
 223       die "No next::method '$label' found for $self" unless $found;
 224
 225       $found;
 226     } };
 227 }
 228
 229 1;
 230
 231 __END__
 232
 233 =pod
 234
 235 =head1 NAME
 236
 237 Class::C3 - A pragma to use the C3 method resolution order algortihm
 238
 239 =head1 SYNOPSIS
 240
 241     package A;
 242     use Class::C3;
 243     sub hello { 'A::hello' }
 244
 245     package B;
 246     use base 'A';
 247     use Class::C3;
 248
 249     package C;
 250     use base 'A';
 251     use Class::C3;
 252
 253     sub hello { 'C::hello' }
 254
 255     package D;
 256     use base ('B', 'C');
 257     use Class::C3;
 258
 259     # Classic Diamond MI pattern
 260     #    <A>
 261     #   /   \
 262     # <B>   <C>
 263     #   \   /
 264     #    <D>
 265
 266     package main;
 267
 268     print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
 269
 270     print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
 271
 272     D->can('hello')->();          # can() also works correctly
 273     UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
 274
 275 =head1 DESCRIPTION
 276
 277 This is currently an experimental pragma to change Perl 5's standard method resolution order
 278 from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution
 279 order.
 280
 281 =head2 What is C3?
 282
 283 C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
 284 inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
 285 and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
 286 Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
 287 default MRO for Parrot objects as well.
 288
 289 =head2 How does C3 work.
 290
 291 C3 works by always preserving local precendence ordering. This essentially means that no class will
 292 appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
 293
 294      <A>
 295     /   \
 296   <B>   <C>
 297     \   /
 298      <D>
 299
 300 The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
 301 though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
 302 (D, B, C, A), which does not have this same issue.
 303
 304 This example is fairly trival, for more complex examples and a deeper explaination, see the links in
 305 the L<SEE ALSO> section.
 306
 307 =head2 How does this module work?
 308
 309 This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module
 310 calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from
 311 the symbol tables of each of those classes, and builds a set of method aliases for the correct
 312 dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases
 313 into the local classes symbol table.
 314
 315 The end result is actually classes with pre-cached method dispatch. However, this caching does not
 316 do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
 317 your classes to be effectively closed. See the L<CAVEATS> section for more details.
 318
 319 =head1 OPTIONAL LOWERCASE PRAGMA
 320
 321 This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
 322 the regular install since lowercase module names are considered I<"bad"> by some people. However I
 323 think that code looks much nicer like this:
 324
 325   package MyClass;
 326   use c3;
 327
 328 The the more clunky:
 329
 330   package MyClass;
 331   use Class::C3;
 332
 333 But hey, it's your choice, thats why it is optional.
 334
 335 =head1 FUNCTIONS
 336
 337 =over 4
 338
 339 =item B<calculateMRO ($class)>
 340
 341 Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
 342
 343 =item B<initialize>
 344
 345 This can be used to initalize the C3 method dispatch tables. You need to call this if you are running
 346 under mod_perl, or in any other environment which does not run the INIT phase of the perl compiler.
 347
 348 NOTE:
 349 This can B<not> be used to re-load the dispatch tables for all classes. Use C<reinitialize> for that.
 350
 351 =item B<uninitialize>
 352
 353 Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
 354 style dispatch order (depth-first, left-to-right).
 355
 356 =item B<reinitialize>
 357
 358 This effectively calls C<uninitialize> followed by C<initialize> the result of which is a reloading of
 359 B<all> the calculated C3 dispatch tables.
 360
 361 It should be noted that if you have a large class library, this could potentially be a rather costly
 362 operation.
 363
 364 =back
 365
 366 =head1 METHOD REDISPATCHING
 367
 368 It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
 369 module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
 370 method along the C3 linearization. This is best show with an examples.
 371
 372   # a classic diamond MI pattern ...
 373      <A>
 374     /   \
 375   <B>   <C>
 376     \   /
 377      <D>
 378
 379   package A;
 380   use c3;
 381   sub foo { 'A::foo' }
 382
 383   package B;
 384   use base 'A';
 385   use c3;
 386   sub foo { 'B::foo => ' . (shift)->next::method() }
 387
 388   package B;
 389   use base 'A';
 390   use c3;
 391   sub foo { 'C::foo => ' . (shift)->next::method() }
 392
 393   package D;
 394   use base ('B', 'C');
 395   use c3;
 396   sub foo { 'D::foo => ' . (shift)->next::method() }
 397
 398   print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo"
 399
 400 A few things to note. First, we do not require you to add on the method name to the C<next::method>
 401 call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
 402 that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
 403
 404 The next thing to keep in mind is that you will need to pass all arguments to C<next::method> it can
 405 not automatically use the current C<@_>.
 406
 407 =head1 CAVEATS
 408
 409 Let me first say, this is an experimental module, and so it should not be used for anything other
 410 then other experimentation for the time being.
 411
 412 That said, it is the authors intention to make this into a completely usable and production stable
 413 module if possible. Time will tell.
 414
 415 And now, onto the caveats.
 416
 417 =over 4
 418
 419 =item Use of C<SUPER::>.
 420
 421 The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
 422 However, it's use in conjuntion with this module is very much not recommended, and in fact very
 423 discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
 424 more details on it's usage above.
 425
 426 =item Changing C<@ISA>.
 427
 428 It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
 429 do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
 430 module, and therefor probably won't even show up. If you do this, you will need to call C<reinitialize>
 431 in order to recalulate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
 432 in F<t/20_reinitialize.t> for more information.
 433
 434 =item Adding/deleting methods from class symbol tables.
 435
 436 This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol
 437 tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will
 438 not be reflected in the calculated MRO. Just as with changing the C<@ISA>, you will need to call
 439 C<reinitialize> for any changes you make to take effect.
 440
 441 =back
 442
 443 =head1 TODO
 444
 445 =over 4
 446
 447 =item More tests
 448
 449 You can never have enough tests :)
 450
 451 =back
 452
 453 =head1 CODE COVERAGE
 454
 455 I use B<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> report on this module's test suite.
 456
 457  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 458  File                           stmt   bran   cond    sub    pod   time  total
 459  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 460  Class/C3.pm                    99.2   93.3   66.7   96.0  100.0   92.8   96.3
 461  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 462  Total                          99.2   93.3   66.7   96.0  100.0   92.8   96.3
 463  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 464
 465 =head1 SEE ALSO
 466
 467 =head2 The original Dylan paper
 468
 469 =over 4
 470
 471 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
 472
 473 =back
 474
 475 =head2 The prototype Perl 6 Object Model uses C3
 476
 477 =over 4
 478
 479 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
 480
 481 =back
 482
 483 =head2 Parrot now uses C3
 484
 485 =over 4
 486
 487 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
 488
 489 =item L<http://use.perl.org/~autrijus/journal/25768>
 490
 491 =back
 492
 493 =head2 Python 2.3 MRO related links
 494
 495 =over 4
 496
 497 =item L<http://www.python.org/2.3/mro.html>
 498
 499 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
 500
 501 =back
 502
 503 =head2 C3 for TinyCLOS
 504
 505 =over 4
 506
 507 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
 508
 509 =back
 510
 511 =head1 AUTHOR
 512
 513 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
 514
 515 =head1 COPYRIGHT AND LICENSE
 516
 517 Copyright 2005 by Infinity Interactive, Inc.
 518
 519 L<http://www.iinteractive.com>
 520
 521 This library is free software; you can redistribute it and/or modify
 522 it under the same terms as Perl itself.
 523
 524 =cut