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