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.13';
  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 sub import {
  33     my $class = caller();
  34     # skip if the caller is main::
  35     # since that is clearly not relevant
  36     return if $class eq 'main';
  37     return if $TURN_OFF_C3;
  38     # make a note to calculate $class
  39     # during INIT phase
  40     $MRO{$class} = undef unless exists $MRO{$class};
  41 }
  42
  43 ## initializers
  44
  45 sub initialize {
  46     # why bother if we don't have anything ...
  47     return unless keys %MRO;
  48     _calculate_method_dispatch_tables();
  49     _apply_method_dispatch_tables();
  50     %next::METHOD_CACHE = ();
  51 }
  52
  53 sub uninitialize {
  54     # why bother if we don't have anything ...
  55     return unless keys %MRO;
  56     _remove_method_dispatch_tables();
  57     %next::METHOD_CACHE = ();
  58 }
  59
  60 sub reinitialize {
  61     uninitialize();
  62     # clean up the %MRO before we re-initialize
  63     $MRO{$_} = undef foreach keys %MRO;
  64     initialize();
  65 }
  66
  67 ## functions for applying C3 to classes
  68
  69 sub _calculate_method_dispatch_tables {
  70     my %merge_cache;
  71     foreach my $class (keys %MRO) {
  72         _calculate_method_dispatch_table($class, \%merge_cache);
  73     }
  74 }
  75
  76 sub _calculate_method_dispatch_table {
  77     my ($class, $merge_cache) = @_;
  78     no strict 'refs';
  79     my @MRO = calculateMRO($class, $merge_cache);
  80     $MRO{$class} = { MRO => \@MRO };
  81     my $has_overload_fallback = 0;
  82     my %methods;
  83     # NOTE:
  84     # we do @MRO[1 .. $#MRO] here because it
  85     # makes no sense to interogate the class
  86     # which you are calculating for.
  87     foreach my $local (@MRO[1 .. $#MRO]) {
  88         # if overload has tagged this module to
  89         # have use "fallback", then we want to
  90         # grab that value
  91         $has_overload_fallback = ${"${local}::()"}
  92             if defined ${"${local}::()"};
  93         foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
  94             # skip if already overriden in local class
  95             next unless !defined *{"${class}::$method"}{CODE};
  96             $methods{$method} = {
  97                 orig => "${local}::$method",
  98                 code => \&{"${local}::$method"}
  99             } unless exists $methods{$method};
 100         }
 101     }
 102     # now stash them in our %MRO table
 103     $MRO{$class}->{methods} = \%methods;
 104     $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
 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     ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
 117         if $MRO{$class}->{has_overload_fallback};
 118     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 119         *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
 120     }
 121 }
 122
 123 sub _remove_method_dispatch_tables {
 124     foreach my $class (keys %MRO) {
 125         _remove_method_dispatch_table($class);
 126     }
 127 }
 128
 129 sub _remove_method_dispatch_table {
 130     my $class = shift;
 131     no strict 'refs';
 132     delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
 133     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 134         delete ${"${class}::"}{$method}
 135             if defined *{"${class}::${method}"}{CODE} &&
 136                (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
 137     }
 138 }
 139
 140 ## functions for calculating C3 MRO
 141
 142 sub calculateMRO {
 143     my ($class, $merge_cache) = @_;
 144     return Algorithm::C3::merge($class, sub {
 145         no strict 'refs';
 146         @{$_[0] . '::ISA'};
 147     }, $merge_cache);
 148 }
 149
 150 package  # hide me from PAUSE
 151     next;
 152
 153 use strict;
 154 use warnings;
 155
 156 use Scalar::Util 'blessed';
 157
 158 our $VERSION = '0.05';
 159
 160 our %METHOD_CACHE;
 161
 162 sub method {
 163     my $indirect = caller() =~ /^(?:next|maybe::next)$/;
 164     my $level = $indirect ? 2 : 1;
 165
 166     my ($method_caller, $label, @label);
 167     while ($method_caller = (caller($level++))[3]) {
 168       @label = (split '::', $method_caller);
 169       $label = pop @label;
 170       last unless
 171         $label eq '(eval)' ||
 172         $label eq '__ANON__';
 173     }
 174     my $caller   = join '::' => @label;
 175     my $self     = $_[0];
 176     my $class    = blessed($self) || $self;
 177
 178     my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
 179
 180         my @MRO = Class::C3::calculateMRO($class);
 181
 182         my $current;
 183         while ($current = shift @MRO) {
 184             last if $caller eq $current;
 185         }
 186
 187         no strict 'refs';
 188         my $found;
 189         foreach my $class (@MRO) {
 190             next if (defined $Class::C3::MRO{$class} &&
 191                      defined $Class::C3::MRO{$class}{methods}{$label});
 192             last if (defined ($found = *{$class . '::' . $label}{CODE}));
 193         }
 194
 195         $found;
 196     };
 197
 198     return $method if $indirect;
 199
 200     die "No next::method '$label' found for $self" if !$method;
 201
 202     goto &{$method};
 203 }
 204
 205 sub can { method($_[0]) }
 206
 207 package  # hide me from PAUSE
 208     maybe::next;
 209
 210 use strict;
 211 use warnings;
 212
 213 our $VERSION = '0.01';
 214
 215 sub method { (next::method($_[0]) || return)->(@_) }
 216
 217 1;
 218
 219 __END__
 220
 221 =pod
 222
 223 =head1 NAME
 224
 225 Class::C3 - A pragma to use the C3 method resolution order algortihm
 226
 227 =head1 SYNOPSIS
 228
 229     package A;
 230     use Class::C3;
 231     sub hello { 'A::hello' }
 232
 233     package B;
 234     use base 'A';
 235     use Class::C3;
 236
 237     package C;
 238     use base 'A';
 239     use Class::C3;
 240
 241     sub hello { 'C::hello' }
 242
 243     package D;
 244     use base ('B', 'C');
 245     use Class::C3;
 246
 247     # Classic Diamond MI pattern
 248     #    <A>
 249     #   /   \
 250     # <B>   <C>
 251     #   \   /
 252     #    <D>
 253
 254     package main;
 255
 256     # initializez the C3 module
 257     # (formerly called in INIT)
 258     Class::C3::initialize();
 259
 260     print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
 261
 262     print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
 263
 264     D->can('hello')->();          # can() also works correctly
 265     UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
 266
 267 =head1 DESCRIPTION
 268
 269 This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right
 270 (a.k.a - pre-order) to the more sophisticated C3 method resolution order.
 271
 272 =head2 What is C3?
 273
 274 C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
 275 inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
 276 and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
 277 Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
 278 default MRO for Parrot objects as well.
 279
 280 =head2 How does C3 work.
 281
 282 C3 works by always preserving local precendence ordering. This essentially means that no class will
 283 appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
 284
 285      <A>
 286     /   \
 287   <B>   <C>
 288     \   /
 289      <D>
 290
 291 The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
 292 though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
 293 (D, B, C, A), which does not have this same issue.
 294
 295 This example is fairly trival, for more complex examples and a deeper explaination, see the links in
 296 the L<SEE ALSO> section.
 297
 298 =head2 How does this module work?
 299
 300 This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is
 301 called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
 302 gathers information from the symbol tables of each of those classes, and builds a set of method
 303 aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
 304 then adds the method aliases into the local classes symbol table.
 305
 306 The end result is actually classes with pre-cached method dispatch. However, this caching does not
 307 do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
 308 your classes to be effectively closed. See the L<CAVEATS> section for more details.
 309
 310 =head1 OPTIONAL LOWERCASE PRAGMA
 311
 312 This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
 313 the regular install since lowercase module names are considered I<"bad"> by some people. However I
 314 think that code looks much nicer like this:
 315
 316   package MyClass;
 317   use c3;
 318
 319 The the more clunky:
 320
 321   package MyClass;
 322   use Class::C3;
 323
 324 But hey, it's your choice, thats why it is optional.
 325
 326 =head1 FUNCTIONS
 327
 328 =over 4
 329
 330 =item B<calculateMRO ($class)>
 331
 332 Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
 333
 334 =item B<initialize>
 335
 336 This B<must be called> to initalize the C3 method dispatch tables, this module B<will not work> if
 337 you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
 338 use C3. Here is a quick code example:
 339
 340   package Foo;
 341   use Class::C3;
 342   # ... Foo methods here
 343
 344   package Bar;
 345   use Class::C3;
 346   use base 'Foo';
 347   # ... Bar methods here
 348
 349   package main;
 350
 351   Class::C3::initialize(); # now it is safe to use Foo and Bar
 352
 353 This function used to be called automatically for you in the INIT phase of the perl compiler, but
 354 that lead to warnings if this module was required at runtime. After discussion with my user base
 355 (the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a
 356 convience. I apologize to anyone this causes problems for (although i would very suprised if I had
 357 any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define
 358 your own INIT method which calls this function.
 359
 360 NOTE:
 361 This can B<not> be used to re-load the dispatch tables for all classes. Use C<reinitialize> for that.
 362
 363 =item B<uninitialize>
 364
 365 Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
 366 style dispatch order (depth-first, left-to-right).
 367
 368 =item B<reinitialize>
 369
 370 This effectively calls C<uninitialize> followed by C<initialize> the result of which is a reloading of
 371 B<all> the calculated C3 dispatch tables.
 372
 373 It should be noted that if you have a large class library, this could potentially be a rather costly
 374 operation.
 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