lib/Class/C3.pm

   1
   2 package Class::C3;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'blessed';
   8 use Algorithm::C3;
   9
  10 our $VERSION = '0.14';
  11
  12 # this is our global stash of both
  13 # MRO's and method dispatch tables
  14 # the structure basically looks like
  15 # this:
  16 #
  17 #   $MRO{$class} = {
  18 #      MRO => [ <class precendence list> ],
  19 #      methods => {
  20 #          orig => <original location of method>,
  21 #          code => \&<ref to original method>
  22 #      },
  23 #      has_overload_fallback => (1 | 0)
  24 #   }
  25 #
  26 our %MRO;
  27
  28 # use these for debugging ...
  29 sub _dump_MRO_table { %MRO }
  30 our $TURN_OFF_C3 = 0;
  31
  32 # state tracking for initialize()/uninitialize()
  33 our $_initialized = 0;
  34
  35 sub import {
  36     my $class = caller();
  37     # skip if the caller is main::
  38     # since that is clearly not relevant
  39     return if $class eq 'main';
  40     return if $TURN_OFF_C3;
  41     # make a note to calculate $class
  42     # during INIT phase
  43     $MRO{$class} = undef unless exists $MRO{$class};
  44 }
  45
  46 ## initializers
  47
  48 sub initialize {
  49     # why bother if we don't have anything ...
  50     return unless keys %MRO;
  51     if($_initialized) {
  52         uninitialize();
  53         $MRO{$_} = undef foreach keys %MRO;
  54     }
  55     _calculate_method_dispatch_tables();
  56     _apply_method_dispatch_tables();
  57     %next::METHOD_CACHE = ();
  58     $_initialized = 1;
  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     $_initialized = 0;
  67 }
  68
  69 sub reinitialize { goto &initialize }
  70
  71 ## functions for applying C3 to classes
  72
  73 sub _calculate_method_dispatch_tables {
  74     my %merge_cache;
  75     foreach my $class (keys %MRO) {
  76         _calculate_method_dispatch_table($class, \%merge_cache);
  77     }
  78 }
  79
  80 sub _calculate_method_dispatch_table {
  81     my ($class, $merge_cache) = @_;
  82     no strict 'refs';
  83     my @MRO = calculateMRO($class, $merge_cache);
  84     $MRO{$class} = { MRO => \@MRO };
  85     my $has_overload_fallback = 0;
  86     my %methods;
  87     # NOTE:
  88     # we do @MRO[1 .. $#MRO] here because it
  89     # makes no sense to interogate the class
  90     # which you are calculating for.
  91     foreach my $local (@MRO[1 .. $#MRO]) {
  92         # if overload has tagged this module to
  93         # have use "fallback", then we want to
  94         # grab that value
  95         $has_overload_fallback = ${"${local}::()"}
  96             if defined ${"${local}::()"};
  97         foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
  98             # skip if already overriden in local class
  99             next unless !defined *{"${class}::$method"}{CODE};
 100             $methods{$method} = {
 101                 orig => "${local}::$method",
 102                 code => \&{"${local}::$method"}
 103             } unless exists $methods{$method};
 104         }
 105     }
 106     # now stash them in our %MRO table
 107     $MRO{$class}->{methods} = \%methods;
 108     $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
 109 }
 110
 111 sub _apply_method_dispatch_tables {
 112     foreach my $class (keys %MRO) {
 113         _apply_method_dispatch_table($class);
 114     }
 115 }
 116
 117 sub _apply_method_dispatch_table {
 118     my $class = shift;
 119     no strict 'refs';
 120     ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
 121         if $MRO{$class}->{has_overload_fallback};
 122     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 123         if ( $method =~ /^\(/ ) {
 124             my $orig = $MRO{$class}->{methods}->{$method}->{orig};
 125             ${"${class}::$method"} = $$orig if defined $$orig;
 126         }
 127         *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
 128     }
 129 }
 130
 131 sub _remove_method_dispatch_tables {
 132     foreach my $class (keys %MRO) {
 133         _remove_method_dispatch_table($class);
 134     }
 135 }
 136
 137 sub _remove_method_dispatch_table {
 138     my $class = shift;
 139     no strict 'refs';
 140     delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
 141     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 142         delete ${"${class}::"}{$method}
 143             if defined *{"${class}::${method}"}{CODE} &&
 144                (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
 145     }
 146 }
 147
 148 ## functions for calculating C3 MRO
 149
 150 sub calculateMRO {
 151     my ($class, $merge_cache) = @_;
 152     return Algorithm::C3::merge($class, sub {
 153         no strict 'refs';
 154         @{$_[0] . '::ISA'};
 155     }, $merge_cache);
 156 }
 157
 158 package  # hide me from PAUSE
 159     next;
 160
 161 use strict;
 162 use warnings;
 163
 164 use Scalar::Util 'blessed';
 165
 166 our $VERSION = '0.05';
 167
 168 our %METHOD_CACHE;
 169
 170 sub method {
 171     my $indirect = caller() =~ /^(?:next|maybe::next)$/;
 172     my $level = $indirect ? 2 : 1;
 173
 174     my ($method_caller, $label, @label);
 175     while ($method_caller = (caller($level++))[3]) {
 176       @label = (split '::', $method_caller);
 177       $label = pop @label;
 178       last unless
 179         $label eq '(eval)' ||
 180         $label eq '__ANON__';
 181     }
 182     my $caller   = join '::' => @label;
 183     my $self     = $_[0];
 184     my $class    = blessed($self) || $self;
 185
 186     my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
 187
 188         my @MRO = Class::C3::calculateMRO($class);
 189
 190         my $current;
 191         while ($current = shift @MRO) {
 192             last if $caller eq $current;
 193         }
 194
 195         no strict 'refs';
 196         my $found;
 197         foreach my $class (@MRO) {
 198             next if (defined $Class::C3::MRO{$class} &&
 199                      defined $Class::C3::MRO{$class}{methods}{$label});
 200             last if (defined ($found = *{$class . '::' . $label}{CODE}));
 201         }
 202
 203         $found;
 204     };
 205
 206     return $method if $indirect;
 207
 208     die "No next::method '$label' found for $self" if !$method;
 209
 210     goto &{$method};
 211 }
 212
 213 sub can { method($_[0]) }
 214
 215 package  # hide me from PAUSE
 216     maybe::next;
 217
 218 use strict;
 219 use warnings;
 220
 221 our $VERSION = '0.01';
 222
 223 sub method { (next::method($_[0]) || return)->(@_) }
 224
 225 1;
 226
 227 __END__
 228
 229 =pod
 230
 231 =head1 NAME
 232
 233 Class::C3 - A pragma to use the C3 method resolution order algortihm
 234
 235 =head1 SYNOPSIS
 236
 237     package A;
 238     use Class::C3;
 239     sub hello { 'A::hello' }
 240
 241     package B;
 242     use base 'A';
 243     use Class::C3;
 244
 245     package C;
 246     use base 'A';
 247     use Class::C3;
 248
 249     sub hello { 'C::hello' }
 250
 251     package D;
 252     use base ('B', 'C');
 253     use Class::C3;
 254
 255     # Classic Diamond MI pattern
 256     #    <A>
 257     #   /   \
 258     # <B>   <C>
 259     #   \   /
 260     #    <D>
 261
 262     package main;
 263
 264     # initializez the C3 module
 265     # (formerly called in INIT)
 266     Class::C3::initialize();
 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 pragma to change Perl 5's standard method resolution order from depth-first left-to-right
 278 (a.k.a - pre-order) to the more sophisticated C3 method resolution order.
 279
 280 =head2 What is C3?
 281
 282 C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
 283 inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
 284 and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
 285 Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
 286 default MRO for Parrot objects as well.
 287
 288 =head2 How does C3 work.
 289
 290 C3 works by always preserving local precendence ordering. This essentially means that no class will
 291 appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
 292
 293      <A>
 294     /   \
 295   <B>   <C>
 296     \   /
 297      <D>
 298
 299 The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
 300 though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
 301 (D, B, C, A), which does not have this same issue.
 302
 303 This example is fairly trival, for more complex examples and a deeper explaination, see the links in
 304 the L<SEE ALSO> section.
 305
 306 =head2 How does this module work?
 307
 308 This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is
 309 called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
 310 gathers information from the symbol tables of each of those classes, and builds a set of method
 311 aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
 312 then adds the method aliases into the local classes symbol table.
 313
 314 The end result is actually classes with pre-cached method dispatch. However, this caching does not
 315 do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
 316 your classes to be effectively closed. See the L<CAVEATS> section for more details.
 317
 318 =head1 OPTIONAL LOWERCASE PRAGMA
 319
 320 This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
 321 the regular install since lowercase module names are considered I<"bad"> by some people. However I
 322 think that code looks much nicer like this:
 323
 324   package MyClass;
 325   use c3;
 326
 327 The the more clunky:
 328
 329   package MyClass;
 330   use Class::C3;
 331
 332 But hey, it's your choice, thats why it is optional.
 333
 334 =head1 FUNCTIONS
 335
 336 =over 4
 337
 338 =item B<calculateMRO ($class)>
 339
 340 Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
 341
 342 =item B<initialize>
 343
 344 This B<must be called> to initalize the C3 method dispatch tables, this module B<will not work> if
 345 you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
 346 use C3. Here is a quick code example:
 347
 348   package Foo;
 349   use Class::C3;
 350   # ... Foo methods here
 351
 352   package Bar;
 353   use Class::C3;
 354   use base 'Foo';
 355   # ... Bar methods here
 356
 357   package main;
 358
 359   Class::C3::initialize(); # now it is safe to use Foo and Bar
 360
 361 This function used to be called automatically for you in the INIT phase of the perl compiler, but
 362 that lead to warnings if this module was required at runtime. After discussion with my user base
 363 (the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a
 364 convience. I apologize to anyone this causes problems for (although i would very suprised if I had
 365 any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define
 366 your own INIT method which calls this function.
 367
 368 NOTE:
 369
 370 If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
 371 clear the MRO cache first.
 372
 373 =item B<uninitialize>
 374
 375 Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
 376 style dispatch order (depth-first, left-to-right).
 377
 378 =item B<reinitialize>
 379
 380 This is an alias for L</initialize> above.
 381
 382 =back
 383
 384 =head1 METHOD REDISPATCHING
 385
 386 It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
 387 module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
 388 method along the C3 linearization. This is best show with an examples.
 389
 390   # a classic diamond MI pattern ...
 391      <A>
 392     /   \
 393   <B>   <C>
 394     \   /
 395      <D>
 396
 397   package A;
 398   use c3;
 399   sub foo { 'A::foo' }
 400
 401   package B;
 402   use base 'A';
 403   use c3;
 404   sub foo { 'B::foo => ' . (shift)->next::method() }
 405
 406   package B;
 407   use base 'A';
 408   use c3;
 409   sub foo { 'C::foo => ' . (shift)->next::method() }
 410
 411   package D;
 412   use base ('B', 'C');
 413   use c3;
 414   sub foo { 'D::foo => ' . (shift)->next::method() }
 415
 416   print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo"
 417
 418 A few things to note. First, we do not require you to add on the method name to the C<next::method>
 419 call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
 420 that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
 421
 422 The next thing to keep in mind is that you will need to pass all arguments to C<next::method> it can
 423 not automatically use the current C<@_>.
 424
 425 If C<next::method> cannot find a next method to re-dispatch the call to, it will throw an exception.
 426 You can use C<next::can> to see if C<next::method> will succeed before you call it like so:
 427
 428   $self->next::method(@_) if $self->next::can;
 429
 430 Additionally, you can use C<maybe::next::method> as a shortcut to only call the next method if it exists.
 431 The previous example could be simply written as:
 432
 433   $self->maybe::next::method(@_);
 434
 435 There are some caveats about using C<next::method>, see below for those.
 436
 437 =head1 CAVEATS
 438
 439 This module used to be labeled as I<experimental>, however it has now been pretty heavily tested by
 440 the good folks over at L<DBIx::Class> and I am confident this module is perfectly usable for
 441 whatever your needs might be.
 442
 443 But there are still caveats, so here goes ...
 444
 445 =over 4
 446
 447 =item Use of C<SUPER::>.
 448
 449 The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
 450 However, it's use in conjuntion with this module is very much not recommended, and in fact very
 451 discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
 452 more details on it's usage above.
 453
 454 =item Changing C<@ISA>.
 455
 456 It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
 457 do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
 458 module, and therefor probably won't even show up. If you do this, you will need to call C<reinitialize>
 459 in order to recalulate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
 460 in F<t/20_reinitialize.t> for more information.
 461
 462 =item Adding/deleting methods from class symbol tables.
 463
 464 This module calculates the MRO for each requested class by interogatting the symbol tables of said classes.
 465 So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in
 466 the calculated MRO. Just as with changing the C<@ISA>, you will need to call C<reinitialize> for any
 467 changes you make to take effect.
 468
 469 =item Calling C<next::method> from methods defined outside the class
 470
 471 There is an edge case when using C<next::method> from within a subroutine which was created in a different
 472 module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which
 473 will not work correctly:
 474
 475   *Foo::foo = sub { (shift)->next::method(@_) };
 476
 477 The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up
 478 in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method>
 479 uses C<caller> to find the name of the method it was called in, it will fail in this case.
 480
 481 But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and
 482 assign a name to an anonymous subroutine for you. Simply do this:
 483
 484   use Sub::Name 'subname';
 485   *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
 486
 487 and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't
 488 manage to find a workaround for it, so until someone gives me a working patch this will be a known
 489 limitation of this module.
 490
 491 =back
 492
 493 =head1 CODE COVERAGE
 494
 495 I use B<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> report on this
 496 module's test suite.
 497
 498  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 499  File                           stmt   bran   cond    sub    pod   time  total
 500  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 501  Class/C3.pm                    98.3   84.4   80.0   96.2  100.0   98.4   94.4
 502  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 503  Total                          98.3   84.4   80.0   96.2  100.0   98.4   94.4
 504  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 505
 506 =head1 SEE ALSO
 507
 508 =head2 The original Dylan paper
 509
 510 =over 4
 511
 512 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
 513
 514 =back
 515
 516 =head2 The prototype Perl 6 Object Model uses C3
 517
 518 =over 4
 519
 520 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
 521
 522 =back
 523
 524 =head2 Parrot now uses C3
 525
 526 =over 4
 527
 528 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
 529
 530 =item L<http://use.perl.org/~autrijus/journal/25768>
 531
 532 =back
 533
 534 =head2 Python 2.3 MRO related links
 535
 536 =over 4
 537
 538 =item L<http://www.python.org/2.3/mro.html>
 539
 540 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
 541
 542 =back
 543
 544 =head2 C3 for TinyCLOS
 545
 546 =over 4
 547
 548 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
 549
 550 =back
 551
 552 =head1 ACKNOWLEGEMENTS
 553
 554 =over 4
 555
 556 =item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class>
 557 and finding many bugs and providing fixes.
 558
 559 =item Thanks to Justin Guenther for making C<next::method> more robust by handling
 560 calls inside C<eval> and anon-subs.
 561
 562 =item Thanks to Robert Norris for adding support for C<next::can> and
 563 C<maybe::next::method>.
 564
 565 =back
 566
 567 =head1 AUTHOR
 568
 569 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
 570
 571 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 572
 573 =head1 COPYRIGHT AND LICENSE
 574
 575 Copyright 2005, 2006 by Infinity Interactive, Inc.
 576
 577 L<http://www.iinteractive.com>
 578
 579 This library is free software; you can redistribute it and/or modify
 580 it under the same terms as Perl itself.
 581
 582 =cut