use warnings;
use Scalar::Util 'blessed';
+use Algorithm::C3;
-our $VERSION = '0.05';
+our $VERSION = '0.14';
# 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 these for debugging ...
sub _dump_MRO_table { %MRO }
our $TURN_OFF_C3 = 0;
+our $_initialized = 0;
sub import {
my $class = caller();
return if $TURN_OFF_C3;
# 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 {
# why bother if we don't have anything ...
return unless keys %MRO;
+ if($_initialized) {
+ uninitialize();
+ $MRO{$_} = undef foreach keys %MRO;
+ }
_calculate_method_dispatch_tables();
_apply_method_dispatch_tables();
%next::METHOD_CACHE = ();
+ $_initialized = 1;
}
sub uninitialize {
return unless keys %MRO;
_remove_method_dispatch_tables();
%next::METHOD_CACHE = ();
+ $_initialized = 0;
}
-sub reinitialize {
- uninitialize();
- # clean up the %MRO before we re-initialize
- $MRO{$_} = undef foreach keys %MRO;
- initialize();
-}
+sub reinitialize { goto &initialize }
## functions for applying C3 to classes
sub _calculate_method_dispatch_tables {
+ 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;
+ 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 {
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_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};
+ 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 @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 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
- );
+ my ($class, $merge_cache) = @_;
+ return Algorithm::C3::merge($class, sub {
+ no strict 'refs';
+ @{$_[0] . '::ISA'};
+ }, $merge_cache);
}
package # hide me from PAUSE
use Scalar::Util 'blessed';
-our $VERSION = '0.03';
+our $VERSION = '0.05';
our %METHOD_CACHE;
sub method {
- my @label = (split '::', (caller(1))[3]);
- my $label = pop @label;
+ my $indirect = caller() =~ /^(?:next|maybe::next)$/;
+ my $level = $indirect ? 2 : 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 $method = $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}));
+ }
+
+ $found;
+ };
- my @MRO = Class::C3::calculateMRO($class);
+ return $method if $indirect;
- my $current;
- while ($current = shift @MRO) {
- last if $caller eq $current;
- }
+ die "No next::method '$label' found for $self" if !$method;
- no strict 'refs';
- my $found;
- foreach my $class (@MRO) {
- last if (defined ($found = *{$class . '::' . $label}{CODE}));
- }
+ goto &{$method};
+}
- die "No next::method '$label' found for $self" unless $found;
+sub can { method($_[0]) }
- $found;
- } };
-}
+package # hide me from PAUSE
+ maybe::next;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+sub method { (next::method($_[0]) || return)->(@_) }
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
=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;
+
+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:
-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->maybe::next::method(@_);
+
+There are some caveats about using C<next::method>, see below for those.
+
+=head1 CAVEATS
-That said, it is the authors intention to make this into a completely usable and production stable
-module if possible. Time will tell.
+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
=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>
=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