use strict;
use warnings;
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.05';
-
-# 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>
-# }
-# }
-#
-my %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;
-}
-
-## 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 %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]) {
- 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;
-}
-
-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';
- 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';
- foreach my $method (keys %{$MRO{$class}->{methods}}) {
- delete ${"${class}::"}{$method};
- }
-}
-
-## 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 @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 $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 ...
- $cand = undef; # otherwise, reject it ...
- }
- die "Inconsistent hierarchy" 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.03';
-
-our %METHOD_CACHE;
-
-sub method {
- my @label = (split '::', (caller(1))[3]);
- my $label = pop @label;
- 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) {
- last if (defined ($found = *{$class . '::' . $label}{CODE}));
- }
-
- die "No next::method '$label' found for $self" unless $found;
-
- $found;
- } };
-}
-
1;
__END__
# <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
=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?
=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
=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>
=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
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;
-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.
+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:
-That said, it is the authors intention to make this into a completely usable and production stable
-module if possible. Time will tell.
+ $self->maybe::next::method(@_);
-And now, onto the caveats.
+There are some caveats about using C<next::method>, see below for those.
+
+=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.
+
+But there are still caveats, so here goes ...
=over 4
=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(@_) };
+
+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.
-=item More 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(@_) };
-You can never have enough tests :)
+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
=head1 CODE COVERAGE
-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.
+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.
---------------------------- ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
---------------------------- ------ ------ ------ ------ ------ ------ ------
- Class/C3.pm 99.2 93.3 66.7 96.0 100.0 92.8 96.3
+ Class/C3.pm 98.3 84.4 80.0 96.2 100.0 98.4 94.4
---------------------------- ------ ------ ------ ------ ------ ------ ------
- Total 99.2 93.3 66.7 96.0 100.0 92.8 96.3
+ Total 98.3 84.4 80.0 96.2 100.0 98.4 94.4
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 SEE ALSO
=back
+=head1 ACKNOWLEGEMENTS
+
+=over 4
+
+=item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class>
+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
projects / gitmo/Class-C3.git / blobdiff