break out most of the code to ::PurePerl
[gitmo/Class-C3.git] / lib / Class / C3.pm
index c86f76d..5c62422 100644 (file)
@@ -4,250 +4,18 @@ package Class::C3;
 use strict;
 use warnings;
 
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.09';
-
-# this is our global stash of both 
-# MRO's and method dispatch tables
-# the structure basically looks like
-# this:
-#
-#   $MRO{$class} = {
-#      MRO => [ <class precendence list> ],
-#      methods => {
-#          orig => <original location of method>,
-#          code => \&<ref to original method>
-#      },
-#      has_overload_fallback => (1 | 0)
-#   }
-#
-our %MRO;
-
-# use these for debugging ...
-sub _dump_MRO_table { %MRO }
-our $TURN_OFF_C3 = 0;
-
-sub import {
-    my $class = caller();
-    # skip if the caller is main::
-    # since that is clearly not relevant
-    return if $class eq 'main';
-    return if $TURN_OFF_C3;
-    # make a note to calculate $class 
-    # during INIT phase
-    $MRO{$class} = undef unless exists $MRO{$class};
-}
-
-## initializers
-
-# NOTE:
-# this will not run under the following
-# conditions:
-#  - mod_perl
-#  - require Class::C3;
-#  - eval "use Class::C3"
-# in all those cases, you need to call 
-# the initialize() function manually
-INIT { initialize() }
-
-sub initialize {
-    # why bother if we don't have anything ...
-    return unless keys %MRO;
-    _calculate_method_dispatch_tables();
-    _apply_method_dispatch_tables();
-    %next::METHOD_CACHE = ();
-}
-
-sub uninitialize {
-    # why bother if we don't have anything ...
-    return unless keys %MRO;    
-    _remove_method_dispatch_tables();    
-    %next::METHOD_CACHE = ();
-}
-
-sub reinitialize {
-    uninitialize();
-    # clean up the %MRO before we re-initialize
-    $MRO{$_} = undef foreach keys %MRO;
-    initialize();
-}
-
-## functions for applying C3 to classes
-
-sub _calculate_method_dispatch_tables {
-    foreach my $class (keys %MRO) {
-        _calculate_method_dispatch_table($class);
-    }
-}
-
-sub _calculate_method_dispatch_table {
-    my $class = shift;
-    no strict 'refs';
-    my @MRO = calculateMRO($class);
-    $MRO{$class} = { MRO => \@MRO };
-    my $has_overload_fallback = 0;
-    my %methods;
-    # NOTE: 
-    # we do @MRO[1 .. $#MRO] here because it
-    # makes no sense to interogate the class
-    # which you are calculating for. 
-    foreach my $local (@MRO[1 .. $#MRO]) {
-        # if overload has tagged this module to 
-        # have use "fallback", then we want to
-        # grab that value 
-        $has_overload_fallback = ${"${local}::()"} 
-            if defined ${"${local}::()"};
-        foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
-            # skip if already overriden in local class
-            next unless !defined *{"${class}::$method"}{CODE};
-            $methods{$method} = {
-                orig => "${local}::$method",
-                code => \&{"${local}::$method"}
-            } unless exists $methods{$method};
-        }
-    }    
-    # now stash them in our %MRO table
-    $MRO{$class}->{methods} = \%methods; 
-    $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;        
-}
-
-sub _apply_method_dispatch_tables {
-    foreach my $class (keys %MRO) {
-        _apply_method_dispatch_table($class);
-    }     
-}
-
-sub _apply_method_dispatch_table {
-    my $class = shift;
-    no strict 'refs';
-    ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
-        if $MRO{$class}->{has_overload_fallback};
-    foreach my $method (keys %{$MRO{$class}->{methods}}) {
-        *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
-    }    
-}
-
-sub _remove_method_dispatch_tables {
-    foreach my $class (keys %MRO) {
-        _remove_method_dispatch_table($class);
-    }       
-}
-
-sub _remove_method_dispatch_table {
-    my $class = shift;
-    no strict 'refs';
-    delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};    
-    foreach my $method (keys %{$MRO{$class}->{methods}}) {
-        delete ${"${class}::"}{$method}
-            if defined *{"${class}::${method}"}{CODE} && 
-               (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});       
-    }   
-}
-
-## functions for calculating C3 MRO
-
-# this function is a perl-port of the 
-# python code on this page:
-#   http://www.python.org/2.3/mro.html
-sub _merge {                
-    my (@seqs) = @_;
-    my $class_being_merged = $seqs[0]->[0];
-    my @res; 
-    while (1) {
-        # remove all empty seqences
-        my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
-        # return the list if we have no more no-empty sequences
-        return @res if not @nonemptyseqs; 
-        my $reject;
-        my $cand; # a canidate ..
-        foreach my $seq (@nonemptyseqs) {
-            $cand = $seq->[0]; # get the head of the list
-            my $nothead;            
-            foreach my $sub_seq (@nonemptyseqs) {
-                # XXX - this is instead of the python "in"
-                my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
-                # NOTE:
-                # jump out as soon as we find one matching
-                # there is no reason not too. However, if 
-                # we find one, then just remove the '&& last'
-                ++$nothead && last if exists $in_tail{$cand};      
-            }
-            last unless $nothead; # leave the loop with our canidate ...
-            $reject = $cand;
-            $cand = undef;        # otherwise, reject it ...
-        }
-        die "Inconsistent hierarchy found while merging '$class_being_merged':\n\t" .
-            "current merge results [\n\t\t" . (join ",\n\t\t" => @res) . "\n\t]\n\t" .
-            "mergeing failed on '$reject'\n" if not $cand;
-        push @res => $cand;
-        # now loop through our non-empties and pop 
-        # off the head if it matches our canidate
-        foreach my $seq (@nonemptyseqs) {
-            shift @{$seq} if $seq->[0] eq $cand;
+our $VERSION = '0.15';
+
+BEGIN {
+    eval { require Class::C3::XS };
+    if($@) {
+        eval { require Class::C3::PurePerl };
+        if($@) {
+            die 'Could not load Class::C3::XS or Class::C3::PurePerl!';
         }
     }
 }
 
-sub calculateMRO {
-    my ($class) = @_;
-    no strict 'refs';
-    return _merge(
-        [ $class ],                                        # the class we are linearizing
-        (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses
-        [ @{"${class}::ISA"} ]                             # a list of all the superclasses    
-    );
-}
-
-package  # hide me from PAUSE
-    next; 
-
-use strict;
-use warnings;
-
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.05';
-
-our %METHOD_CACHE;
-
-sub method {
-    my $level = 1;
-    my ($method_caller, $label, @label);
-    while ($method_caller = (caller($level++))[3]) {
-      @label = (split '::', $method_caller);
-      $label = pop @label;
-      last unless
-        $label eq '(eval)' ||
-        $label eq '__ANON__';
-    }
-    my $caller   = join '::' => @label;    
-    my $self     = $_[0];
-    my $class    = blessed($self) || $self;
-    
-    goto &{ $METHOD_CACHE{"$class|$caller|$label"} ||= do {
-
-      my @MRO = Class::C3::calculateMRO($class);
-
-      my $current;
-      while ($current = shift @MRO) {
-          last if $caller eq $current;
-      }
-
-      no strict 'refs';
-      my $found;
-      foreach my $class (@MRO) {
-          next if (defined $Class::C3::MRO{$class} && 
-                   defined $Class::C3::MRO{$class}{methods}{$label});          
-          last if (defined ($found = *{$class . '::' . $label}{CODE}));
-      }
-
-      die "No next::method '$label' found for $self" unless $found;
-
-      $found;
-    } };
-}
-
 1;
 
 __END__
@@ -286,6 +54,10 @@ Class::C3 - A pragma to use the C3 method resolution order algortihm
     #    <D>
 
     package main;
+    
+    # initializez the C3 module 
+    # (formerly called in INIT)
+    Class::C3::initialize();  
 
     print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
 
@@ -296,9 +68,8 @@ Class::C3 - A pragma to use the C3 method resolution order algortihm
 
 =head1 DESCRIPTION
 
-This is currently an experimental pragma to change Perl 5's standard method resolution order 
-from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution
-order. 
+This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right 
+(a.k.a - pre-order) to the more sophisticated C3 method resolution order. 
 
 =head2 What is C3?
 
@@ -328,11 +99,11 @@ the L<SEE ALSO> section.
 
 =head2 How does this module work?
 
-This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module 
-calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from 
-the symbol tables of each of those classes, and builds a set of method aliases for the correct 
-dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases
-into the local classes symbol table. 
+This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is 
+called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then 
+gathers information from the symbol tables of each of those classes, and builds a set of method 
+aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it 
+then adds the method aliases into the local classes symbol table. 
 
 The end result is actually classes with pre-cached method dispatch. However, this caching does not
 do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
@@ -364,11 +135,34 @@ Given a C<$class> this will return an array of class names in the proper C3 meth
 
 =item B<initialize>
 
-This can be used to initalize the C3 method dispatch tables. You need to call this if you are running
-under mod_perl, or in any other environment which does not run the INIT phase of the perl compiler.
+This B<must be called> to initalize the C3 method dispatch tables, this module B<will not work> if 
+you do not do this. It is advised to do this as soon as possible B<after> loading any classes which 
+use C3. Here is a quick code example:
+  
+  package Foo;
+  use Class::C3;
+  # ... Foo methods here
+  
+  package Bar;
+  use Class::C3;
+  use base 'Foo';
+  # ... Bar methods here
+  
+  package main;
+  
+  Class::C3::initialize(); # now it is safe to use Foo and Bar
+
+This function used to be called automatically for you in the INIT phase of the perl compiler, but 
+that lead to warnings if this module was required at runtime. After discussion with my user base 
+(the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a 
+convience. I apologize to anyone this causes problems for (although i would very suprised if I had 
+any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define 
+your own INIT method which calls this function. 
 
 NOTE: 
-This can B<not> be used to re-load the dispatch tables for all classes. Use C<reinitialize> for that.
+
+If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
+clear the MRO cache first.
 
 =item B<uninitialize>
 
@@ -377,11 +171,7 @@ style dispatch order (depth-first, left-to-right).
 
 =item B<reinitialize>
 
-This effectively calls C<uninitialize> followed by C<initialize> the result of which is a reloading of
-B<all> the calculated C3 dispatch tables. 
-
-It should be noted that if you have a large class library, this could potentially be a rather costly 
-operation.
+This is an alias for L</initialize> above.
 
 =back
 
@@ -426,15 +216,25 @@ that you cannot dispatch to a method of a different name (this is how C<NEXT::>
 The next thing to keep in mind is that you will need to pass all arguments to C<next::method> it can 
 not automatically use the current C<@_>. 
 
-=head1 CAVEATS
+If C<next::method> cannot find a next method to re-dispatch the call to, it will throw an exception.
+You can use C<next::can> to see if C<next::method> will succeed before you call it like so:
+
+  $self->next::method(@_) if $self->next::can; 
+
+Additionally, you can use C<maybe::next::method> as a shortcut to only call the next method if it exists. 
+The previous example could be simply written as:
+
+  $self->maybe::next::method(@_);
 
-Let me first say, this is an experimental module, and so it should not be used for anything other 
-then other experimentation for the time being. 
+There are some caveats about using C<next::method>, see below for those.
 
-That said, it is the authors intention to make this into a completely usable and production stable 
-module if possible. Time will tell.
+=head1 CAVEATS
+
+This module used to be labeled as I<experimental>, however it has now been pretty heavily tested by 
+the good folks over at L<DBIx::Class> and I am confident this module is perfectly usable for 
+whatever your needs might be. 
 
-And now, onto the caveats.
+But there are still caveats, so here goes ...
 
 =over 4
 
@@ -455,20 +255,32 @@ in F<t/20_reinitialize.t> for more information.
 
 =item Adding/deleting methods from class symbol tables.
 
-This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol
-tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will
-not be reflected in the calculated MRO. Just as with changing the C<@ISA>, you will need to call 
-C<reinitialize> for any changes you make to take effect.
+This module calculates the MRO for each requested class by interogatting the symbol tables of said classes. 
+So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in 
+the calculated MRO. Just as with changing the C<@ISA>, you will need to call C<reinitialize> for any 
+changes you make to take effect.
 
-=back
+=item Calling C<next::method> from methods defined outside the class
 
-=head1 TODO
+There is an edge case when using C<next::method> from within a subroutine which was created in a different 
+module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which 
+will not work correctly:
 
-=over 4
+  *Foo::foo = sub { (shift)->next::method(@_) };
 
-=item More tests
+The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up 
+in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method> 
+uses C<caller> to find the name of the method it was called in, it will fail in this case. 
 
-You can never have enough tests :)
+But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and 
+assign a name to an anonymous subroutine for you. Simply do this:
+    
+  use Sub::Name 'subname';
+  *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
+
+and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't 
+manage to find a workaround for it, so until someone gives me a working patch this will be a known 
+limitation of this module.
 
 =back
 
@@ -480,9 +292,9 @@ module's test suite.
  ---------------------------- ------ ------ ------ ------ ------ ------ ------
  File                           stmt   bran   cond    sub    pod   time  total
  ---------------------------- ------ ------ ------ ------ ------ ------ ------
- Class/C3.pm                    98.6   90.9   73.3   96.0  100.0   96.8   95.3
+ Class/C3.pm                    98.3   84.4   80.0   96.2  100.0   98.4   94.4
  ---------------------------- ------ ------ ------ ------ ------ ------ ------
- Total                          98.6   90.9   73.3   96.0  100.0   96.8   95.3
+ Total                          98.3   84.4   80.0   96.2  100.0   98.4   94.4
  ---------------------------- ------ ------ ------ ------ ------ ------ ------
 
 =head1 SEE ALSO
@@ -541,19 +353,24 @@ and finding many bugs and providing fixes.
 =item Thanks to Justin Guenther for making C<next::method> more robust by handling 
 calls inside C<eval> and anon-subs.
 
+=item Thanks to Robert Norris for adding support for C<next::can> and 
+C<maybe::next::method>.
+
 =back
 
 =head1 AUTHOR
 
 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
 
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
 =head1 COPYRIGHT AND LICENSE
 
-Copyright 2005 by Infinity Interactive, Inc.
+Copyright 2005, 2006 by Infinity Interactive, Inc.
 
 L<http://www.iinteractive.com>
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself. 
 
-=cut
\ No newline at end of file
+=cut