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;
  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 $has_overload_fallback && 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 !defined &{"${class}::()"}
 122            && defined $MRO{$class}->{has_overload_fallback};
 123     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 124         if ( $method =~ /^\(/ ) {
 125             my $orig = $MRO{$class}->{methods}->{$method}->{orig};
 126             ${"${class}::$method"} = $$orig if defined $$orig;
 127         }
 128         *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
 129     }
 130 }
 131
 132 sub _remove_method_dispatch_tables {
 133     foreach my $class (keys %MRO) {
 134         _remove_method_dispatch_table($class);
 135     }
 136 }
 137
 138 sub _remove_method_dispatch_table {
 139     my $class = shift;
 140     no strict 'refs';
 141     delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
 142     foreach my $method (keys %{$MRO{$class}->{methods}}) {
 143         delete ${"${class}::"}{$method}
 144             if defined *{"${class}::${method}"}{CODE} &&
 145                (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
 146     }
 147 }
 148
 149 ## functions for calculating C3 MRO
 150
 151 sub calculateMRO {
 152     my ($class, $merge_cache) = @_;
 153     return Algorithm::C3::merge($class, sub {
 154         no strict 'refs';
 155         @{$_[0] . '::ISA'};
 156     }, $merge_cache);
 157 }
 158
 159 package  # hide me from PAUSE
 160     next;
 161
 162 use strict;
 163 use warnings;
 164
 165 use Scalar::Util 'blessed';
 166
 167 our $VERSION = '0.05';
 168
 169 our %METHOD_CACHE;
 170
 171 sub method {
 172     my $indirect = caller() =~ /^(?:next|maybe::next)$/;
 173     my $level = $indirect ? 2 : 1;
 174
 175     my ($method_caller, $label, @label);
 176     while ($method_caller = (caller($level++))[3]) {
 177       @label = (split '::', $method_caller);
 178       $label = pop @label;
 179       last unless
 180         $label eq '(eval)' ||
 181         $label eq '__ANON__';
 182     }
 183     my $caller   = join '::' => @label;
 184     my $self     = $_[0];
 185     my $class    = blessed($self) || $self;
 186
 187     my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
 188
 189         my @MRO = Class::C3::calculateMRO($class);
 190
 191         my $current;
 192         while ($current = shift @MRO) {
 193             last if $caller eq $current;
 194         }
 195
 196         no strict 'refs';
 197         my $found;
 198         foreach my $class (@MRO) {
 199             next if (defined $Class::C3::MRO{$class} &&
 200                      defined $Class::C3::MRO{$class}{methods}{$label});
 201             last if (defined ($found = *{$class . '::' . $label}{CODE}));
 202         }
 203
 204         $found;
 205     };
 206
 207     return $method if $indirect;
 208
 209     die "No next::method '$label' found for $self" if !$method;
 210
 211     goto &{$method};
 212 }
 213
 214 sub can { method($_[0]) }
 215
 216 package  # hide me from PAUSE
 217     maybe::next;
 218
 219 use strict;
 220 use warnings;
 221
 222 our $VERSION = '0.01';
 223
 224 sub method { (next::method($_[0]) || return)->(@_) }
 225
 226 1;
 227
 228 __END__
 229
 230 =pod
 231
 232 =head1 NAME
 233
 234 Class::C3 - A pragma to use the C3 method resolution order algortihm
 235
 236 =head1 SYNOPSIS
 237
 238     package A;
 239     use Class::C3;
 240     sub hello { 'A::hello' }
 241
 242     package B;
 243     use base 'A';
 244     use Class::C3;
 245
 246     package C;
 247     use base 'A';
 248     use Class::C3;
 249
 250     sub hello { 'C::hello' }
 251
 252     package D;
 253     use base ('B', 'C');
 254     use Class::C3;
 255
 256     # Classic Diamond MI pattern
 257     #    <A>
 258     #   /   \
 259     # <B>   <C>
 260     #   \   /
 261     #    <D>
 262
 263     package main;
 264
 265     # initializez the C3 module
 266     # (formerly called in INIT)
 267     Class::C3::initialize();
 268
 269     print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
 270
 271     print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
 272
 273     D->can('hello')->();          # can() also works correctly
 274     UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
 275
 276 =head1 DESCRIPTION
 277
 278 This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right
 279 (a.k.a - pre-order) to the more sophisticated C3 method resolution 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. When C<Class::C3::initialize> is
 310 called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
 311 gathers information from the symbol tables of each of those classes, and builds a set of method
 312 aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
 313 then adds the method aliases 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 B<must be called> to initalize the C3 method dispatch tables, this module B<will not work> if
 346 you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
 347 use C3. Here is a quick code example:
 348
 349   package Foo;
 350   use Class::C3;
 351   # ... Foo methods here
 352
 353   package Bar;
 354   use Class::C3;
 355   use base 'Foo';
 356   # ... Bar methods here
 357
 358   package main;
 359
 360   Class::C3::initialize(); # now it is safe to use Foo and Bar
 361
 362 This function used to be called automatically for you in the INIT phase of the perl compiler, but
 363 that lead to warnings if this module was required at runtime. After discussion with my user base
 364 (the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a
 365 convience. I apologize to anyone this causes problems for (although i would very suprised if I had
 366 any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define
 367 your own INIT method which calls this function.
 368
 369 NOTE:
 370
 371 If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
 372 clear the MRO cache first.
 373
 374 =item B<uninitialize>
 375
 376 Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
 377 style dispatch order (depth-first, left-to-right).
 378
 379 =item B<reinitialize>
 380
 381 This is an alias for L</initialize> above.
 382
 383 =back
 384
 385 =head1 METHOD REDISPATCHING
 386
 387 It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
 388 module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
 389 method along the C3 linearization. This is best show with an examples.
 390
 391   # a classic diamond MI pattern ...
 392      <A>
 393     /   \
 394   <B>   <C>
 395     \   /
 396      <D>
 397
 398   package A;
 399   use c3;
 400   sub foo { 'A::foo' }
 401
 402   package B;
 403   use base 'A';
 404   use c3;
 405   sub foo { 'B::foo => ' . (shift)->next::method() }
 406
 407   package B;
 408   use base 'A';
 409   use c3;
 410   sub foo { 'C::foo => ' . (shift)->next::method() }
 411
 412   package D;
 413   use base ('B', 'C');
 414   use c3;
 415   sub foo { 'D::foo => ' . (shift)->next::method() }
 416
 417   print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo"
 418
 419 A few things to note. First, we do not require you to add on the method name to the C<next::method>
 420 call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
 421 that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
 422
 423 The next thing to keep in mind is that you will need to pass all arguments to C<next::method> it can
 424 not automatically use the current C<@_>.
 425
 426 If C<next::method> cannot find a next method to re-dispatch the call to, it will throw an exception.
 427 You can use C<next::can> to see if C<next::method> will succeed before you call it like so:
 428
 429   $self->next::method(@_) if $self->next::can;
 430
 431 Additionally, you can use C<maybe::next::method> as a shortcut to only call the next method if it exists.
 432 The previous example could be simply written as:
 433
 434   $self->maybe::next::method(@_);
 435
 436 There are some caveats about using C<next::method>, see below for those.
 437
 438 =head1 CAVEATS
 439
 440 This module used to be labeled as I<experimental>, however it has now been pretty heavily tested by
 441 the good folks over at L<DBIx::Class> and I am confident this module is perfectly usable for
 442 whatever your needs might be.
 443
 444 But there are still caveats, so here goes ...
 445
 446 =over 4
 447
 448 =item Use of C<SUPER::>.
 449
 450 The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
 451 However, it's use in conjuntion with this module is very much not recommended, and in fact very
 452 discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
 453 more details on it's usage above.
 454
 455 =item Changing C<@ISA>.
 456
 457 It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
 458 do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
 459 module, and therefor probably won't even show up. If you do this, you will need to call C<reinitialize>
 460 in order to recalulate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
 461 in F<t/20_reinitialize.t> for more information.
 462
 463 =item Adding/deleting methods from class symbol tables.
 464
 465 This module calculates the MRO for each requested class by interogatting the symbol tables of said classes.
 466 So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in
 467 the calculated MRO. Just as with changing the C<@ISA>, you will need to call C<reinitialize> for any
 468 changes you make to take effect.
 469
 470 =item Calling C<next::method> from methods defined outside the class
 471
 472 There is an edge case when using C<next::method> from within a subroutine which was created in a different
 473 module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which
 474 will not work correctly:
 475
 476   *Foo::foo = sub { (shift)->next::method(@_) };
 477
 478 The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up
 479 in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method>
 480 uses C<caller> to find the name of the method it was called in, it will fail in this case.
 481
 482 But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and
 483 assign a name to an anonymous subroutine for you. Simply do this:
 484
 485   use Sub::Name 'subname';
 486   *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
 487
 488 and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't
 489 manage to find a workaround for it, so until someone gives me a working patch this will be a known
 490 limitation of this module.
 491
 492 =back
 493
 494 =head1 CODE COVERAGE
 495
 496 I use B<Devel::Cover> to test the code coverage of my tests, below is the B<Devel::Cover> report on this
 497 module's test suite.
 498
 499  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 500  File                           stmt   bran   cond    sub    pod   time  total
 501  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 502  Class/C3.pm                    98.3   84.4   80.0   96.2  100.0   98.4   94.4
 503  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 504  Total                          98.3   84.4   80.0   96.2  100.0   98.4   94.4
 505  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 506
 507 =head1 SEE ALSO
 508
 509 =head2 The original Dylan paper
 510
 511 =over 4
 512
 513 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
 514
 515 =back
 516
 517 =head2 The prototype Perl 6 Object Model uses C3
 518
 519 =over 4
 520
 521 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
 522
 523 =back
 524
 525 =head2 Parrot now uses C3
 526
 527 =over 4
 528
 529 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
 530
 531 =item L<http://use.perl.org/~autrijus/journal/25768>
 532
 533 =back
 534
 535 =head2 Python 2.3 MRO related links
 536
 537 =over 4
 538
 539 =item L<http://www.python.org/2.3/mro.html>
 540
 541 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
 542
 543 =back
 544
 545 =head2 C3 for TinyCLOS
 546
 547 =over 4
 548
 549 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
 550
 551 =back
 552
 553 =head1 ACKNOWLEGEMENTS
 554
 555 =over 4
 556
 557 =item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class>
 558 and finding many bugs and providing fixes.
 559
 560 =item Thanks to Justin Guenther for making C<next::method> more robust by handling
 561 calls inside C<eval> and anon-subs.
 562
 563 =item Thanks to Robert Norris for adding support for C<next::can> and
 564 C<maybe::next::method>.
 565
 566 =back
 567
 568 =head1 AUTHOR
 569
 570 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
 571
 572 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 573
 574 =head1 COPYRIGHT AND LICENSE
 575
 576 Copyright 2005, 2006 by Infinity Interactive, Inc.
 577
 578 L<http://www.iinteractive.com>
 579
 580 This library is free software; you can redistribute it and/or modify
 581 it under the same terms as Perl itself.
 582
 583 =cut