use Scalar::Util 'blessed';
-our $VERSION = '0.02';
+our $VERSION = '0.09';
# 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 }
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
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 {
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};
}
}
# 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});
}
}
# 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
# 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};
+ ++$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" if not $cand;
+ 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
);
}
+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__
=back
+=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<@_>.
+
=head1 CAVEATS
Let me first say, this is an experimental module, and so it should not be used for anything other
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>.
You can never have enough tests :)
-=item call-next-method / NEXT:: / next METHOD
+=back
-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.
+=head1 CODE COVERAGE
-=back
+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 98.6 90.9 73.3 96.0 100.0 96.8 95.3
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ Total 98.6 90.9 73.3 96.0 100.0 96.8 95.3
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
=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.
+
+=back
+
=head1 AUTHOR
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
projects / gitmo/Class-C3.git / blobdiff