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