use strict;
use warnings;
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.02';
+our $VERSION = '0.15_01';
+
+our $C3_IN_CORE;
+
+BEGIN {
+ eval "require mro"; # XXX in the future, this should be a version check
+ if($@) {
+ die $@ if $@ !~ /locate/;
+# eval "require Class::C3::XS";
+# if($@) {
+# die $@ if $@ !~ /locate/;
+ eval "require Algorithm::C3; require Class::C3::next";
+ die $@ if $@;
+# }
+ }
+ else {
+ $C3_IN_CORE = 1;
+ }
+}
# this is our global stash of both
# MRO's and method dispatch tables
# methods => {
# orig => <original location of method>,
# code => \&<ref to original method>
-# }
+# },
+# has_overload_fallback => (1 | 0)
# }
#
-my %MRO;
+our %MRO;
-# use this for debugging ...
+# use these for debugging ...
sub _dump_MRO_table { %MRO }
-
our $TURN_OFF_C3 = 0;
+# state tracking for initialize()/uninitialize()
+our $_initialized = 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;
+ mro::set_mro($class, 'c3') if $C3_IN_CORE;
+
# make a note to calculate $class
# during INIT phase
- $MRO{$class} = undef;
+ $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 {
+ %next::METHOD_CACHE = ();
# why bother if we don't have anything ...
return unless keys %MRO;
- _calculate_method_dispatch_tables();
- _apply_method_dispatch_tables();
+ if($C3_IN_CORE) {
+ mro::set_mro($_, 'c3') for keys %MRO;
+ }
+ else {
+ if($_initialized) {
+ uninitialize();
+ $MRO{$_} = undef foreach keys %MRO;
+ }
+ _calculate_method_dispatch_tables();
+ _apply_method_dispatch_tables();
+ $_initialized = 1;
+ }
+}
+
+sub uninitialize {
+ # why bother if we don't have anything ...
+ %next::METHOD_CACHE = ();
+ return unless keys %MRO;
+ if($C3_IN_CORE) {
+ mro::set_mro($_, 'dfs') for keys %MRO;
+ }
+ else {
+ _remove_method_dispatch_tables();
+ $_initialized = 0;
+ }
}
+sub reinitialize { goto &initialize }
+
## functions for applying C3 to classes
sub _calculate_method_dispatch_tables {
+ return if $C3_IN_CORE;
+ my %merge_cache;
foreach my $class (keys %MRO) {
- _calculate_method_dispatch_table($class);
+ _calculate_method_dispatch_table($class, \%merge_cache);
}
}
sub _calculate_method_dispatch_table {
- my $class = shift;
+ return if $C3_IN_CORE;
+ my ($class, $merge_cache) = @_;
no strict 'refs';
- my @MRO = calculateMRO($class);
+ my @MRO = calculateMRO($class, $merge_cache);
$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};
}
}
# now stash them in our %MRO table
- $MRO{$class}->{methods} = \%methods;
+ $MRO{$class}->{methods} = \%methods;
+ $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
}
sub _apply_method_dispatch_tables {
+ return if $C3_IN_CORE;
foreach my $class (keys %MRO) {
_apply_method_dispatch_table($class);
}
}
sub _apply_method_dispatch_table {
+ return if $C3_IN_CORE;
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};
}
}
-## 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;
- }
- }
+sub _remove_method_dispatch_tables {
+ return if $C3_IN_CORE;
+ foreach my $class (keys %MRO) {
+ _remove_method_dispatch_table($class);
+ }
}
-sub calculateMRO {
- my ($class) = @_;
+sub _remove_method_dispatch_table {
+ return if $C3_IN_CORE;
+ my $class = shift;
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
- );
+ 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});
+ }
+}
+
+sub calculateMRO {
+ my ($class, $merge_cache) = @_;
+
+ return @{mro::get_linear_isa($class)} if $C3_IN_CORE;
+
+ return Algorithm::C3::merge($class, sub {
+ no strict 'refs';
+ @{$_[0] . '::ISA'};
+ }, $merge_cache);
}
1;
# <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
D->can('hello')->(); # can() also works correctly
UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
+=head1 SPECIAL NOTE FOR 0.15_01
+
+To try this with the experimental perl core c3 patch,
+download a recent copy perl-current:
+
+http://mirrors.develooper.com/perl/APC/perl-current-snap/perl-current@30943.tar.bz2
+
+apply the enclosed c3.patch, and install this perl:
+
+sh Configure -Dusedevel -Dprefix=/where/I/want/it -d -e && make && make test && make install
+
+then try your C3-using software against this perl + Class::C3 0.15_01.
+
=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. This is because it does not first
-return the classes to their virginal state, which would need to happen in order for the dispatch tables
-to be properly reloaded.
+
+If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
+clear the MRO cache first.
+
+=item B<uninitialize>
+
+Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
+style dispatch order (depth-first, left-to-right).
+
+=item B<reinitialize>
+
+This is an alias for L</initialize> above.
=back
-=head1 CAVEATS
+=head1 METHOD REDISPATCHING
+
+It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
+module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
+method along the C3 linearization. This is best show with an examples.
+
+ # a classic diamond MI pattern ...
+ <A>
+ / \
+ <B> <C>
+ \ /
+ <D>
+
+ package A;
+ use c3;
+ sub foo { 'A::foo' }
+
+ package B;
+ use base 'A';
+ use c3;
+ sub foo { 'B::foo => ' . (shift)->next::method() }
+
+ package B;
+ use base 'A';
+ use c3;
+ sub foo { 'C::foo => ' . (shift)->next::method() }
+
+ package D;
+ use base ('B', 'C');
+ use c3;
+ sub foo { 'D::foo => ' . (shift)->next::method() }
+
+ print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo"
+
+A few things to note. First, we do not require you to add on the method name to the C<next::method>
+call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
+that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
+
+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<@_>.
+
+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:
-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.
+ $self->next::method(@_) if $self->next::can;
-That said, it is the authors intention to make this into a completely usable and production stable
-module if possible. Time will tell.
+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:
-And now, onto the caveats.
+ $self->maybe::next::method(@_);
+
+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
The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
However, it's use in conjuntion with this module is very much not recommended, and in fact very
-discouraged. In the future I plan to support a C<NEXT::> style interface to be used to move to the
-next most appropriate method in the MRO.
+discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
+more details on it's usage above.
=item Changing C<@ISA>.
It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
-module, and therefor probably won't even show up. I am considering some kind of C<recalculateMRO> function
-which can be used to recalculate the MRO on demand at runtime, but that is still off in the future.
+module, and therefor probably won't even show up. If you do this, you will need to call C<reinitialize>
+in order to recalulate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
+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.
+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
-
-=head1 TODO
+=item Calling C<next::method> from methods defined outside the class
-=over 4
+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:
-=item More tests
+ *Foo::foo = sub { (shift)->next::method(@_) };
-You can never have enough 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.
-I need to convert the other MRO and class-precendence-list related tests from the Perl6-MetaModel (see link
-in L<SEE ALSO>). In addition, I need to add some method checks to these tests as well.
+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(@_) };
-=item call-next-method / NEXT:: / 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.
-I am contemplating some kind of psudeo-package which can dispatch to the next most relevant method in the
-MRO. This should not be too hard to implement when the time comes.
+=back
-=item recalculateMRO
+=head1 CODE COVERAGE
-This being Perl, it would be remiss of me to force people to close thier classes at runtime. So I need to
-develop a means for recalculating the MRO for a given class.
+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.
-=back
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ File stmt bran cond sub pod time total
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ Class/C3.pm 98.3 84.4 80.0 96.2 100.0 98.4 94.4
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ 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