X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FC3.pm;h=73e8228627a17b107c8af6b286c8ce7aac5f21ce;hb=f4a893b2743451ba7414466464e0e8d843458cfa;hp=3768c47c36974a382d9aad7001baf8dfbaddcae9;hpb=d401eda1e68a148b69c4e4992de7814fcaa44225;p=gitmo%2FClass-C3.git diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm index 3768c47..73e8228 100644 --- a/lib/Class/C3.pm +++ b/lib/Class/C3.pm @@ -5,8 +5,9 @@ use strict; use warnings; use Scalar::Util 'blessed'; +use Algorithm::C3; -our $VERSION = '0.02'; +our $VERSION = '0.13'; # this is our global stash of both # MRO's and method dispatch tables @@ -18,14 +19,14 @@ our $VERSION = '0.02'; # methods => { # orig => , # code => \& -# } +# }, +# 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; sub import { @@ -36,47 +37,59 @@ sub import { 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; _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 { + 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}; @@ -87,7 +100,8 @@ sub _calculate_method_dispatch_table { } } # 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 { @@ -99,60 +113,107 @@ 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_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 @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 ... +sub calculateMRO { + my ($class, $merge_cache) = @_; + return Algorithm::C3::merge($class, sub { + no strict 'refs'; + @{$_[0] . '::ISA'}; + }, $merge_cache); +} + +package # hide me from PAUSE + next; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +our $VERSION = '0.05'; + +our %METHOD_CACHE; + +sub method { + 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; + + 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; } - 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; + + 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; + }; -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 - ); + return $method if $indirect; + + die "No next::method '$label' found for $self" if !$method; + + goto &{$method}; } +sub can { method($_[0]) } + +package # hide me from PAUSE + maybe::next; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +sub method { (next::method($_[0]) || return)->(@_) } + 1; __END__ @@ -191,6 +252,10 @@ Class::C3 - A pragma to use the C3 method resolution order algortihm # 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 @@ -201,9 +266,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? @@ -233,11 +297,11 @@ the L 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. 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 is +called, this module calculates the MRO of all the classes which called C. 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 @@ -269,25 +333,108 @@ Given a C<$class> this will return an array of class names in the proper C3 meth =item B -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 to initalize the C3 method dispatch tables, this module B if +you do not do this. It is advised to do this as soon as possible B 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 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 folks). The simplest solution of course is to define +your own INIT method which calls this function. NOTE: -This can B 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. +This can B be used to re-load the dispatch tables for all classes. Use C for that. + +=item B + +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 + +This effectively calls C followed by C the result of which is a reloading of +B 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. =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 or C which will re-dispatch the +method along the C3 linearization. This is best show with an examples. + + # a classic diamond MI pattern ... + + / \ + + \ / + + + 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 +call (this is unlike C and C 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 behaves as well). -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. +The next thing to keep in mind is that you will need to pass all arguments to C it can +not automatically use the current C<@_>. -That said, it is the authors intention to make this into a completely usable and production stable -module if possible. Time will tell. +If C cannot find a next method to re-dispatch the call to, it will throw an exception. +You can use C to see if C will succeed before you call it like so: -And now, onto the caveats. + $self->next::method(@_) if $self->next::can; + +Additionally, you can use C as a shortcut to only call the next method if it exists. +The previous example could be simply written as: + + $self->maybe::next::method(@_); + +There are some caveats about using C, see below for those. + +=head1 CAVEATS + +This module used to be labeled as I, however it has now been pretty heavily tested by +the good folks over at L 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 @@ -295,46 +442,60 @@ And now, onto the caveats. The idea of C 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 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 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 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 +in order to recalulate B method dispatch tables. See the C documentation and an example +in F 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 for any +changes you make to take effect. -=back +=item Calling C from methods defined outside the class -=head1 TODO +There is an edge case when using C 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 as you might expect. Since C +uses C to find the name of the method it was called in, it will fail in this case. -You can never have enough tests :) - -I need to convert the other MRO and class-precendence-list related tests from the Perl6-MetaModel (see link -in L). 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 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 to test the code coverage of my tests, below is the B 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 @@ -382,17 +543,32 @@ develop a means for recalculating the MRO for a given class. =back +=head1 ACKNOWLEGEMENTS + +=over 4 + +=item Thanks to Matt S. Trout for using this module in his module L +and finding many bugs and providing fixes. + +=item Thanks to Justin Guenther for making C more robust by handling +calls inside C and anon-subs. + +=item Thanks to Robert Norris for adding support for C and +C. + +=back + =head1 AUTHOR Stevan Little, Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2005 by Infinity Interactive, Inc. +Copyright 2005, 2006 by Infinity Interactive, Inc. L 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