From: Brandon L Black Date: Fri, 5 Jan 2007 02:07:32 +0000 (+0000) Subject: break out most of the code to ::PurePerl X-Git-Tag: 0.16~1^2~17 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ecb0388de108f3f6fe103a3ca4f6e28e26892a70;p=gitmo%2FClass-C3.git break out most of the code to ::PurePerl --- diff --git a/lib/Class/C3.pm b/lib/Class/C3.pm index a9158ed..5c62422 100644 --- a/lib/Class/C3.pm +++ b/lib/Class/C3.pm @@ -4,220 +4,18 @@ package Class::C3; use strict; use warnings; -use Scalar::Util 'blessed'; -use Algorithm::C3; - -our $VERSION = '0.14'; - -# this is our global stash of both -# MRO's and method dispatch tables -# the structure basically looks like -# this: -# -# $MRO{$class} = { -# MRO => [ ], -# methods => { -# orig => , -# code => \& -# }, -# has_overload_fallback => (1 | 0) -# } -# -our %MRO; - -# 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; - # make a note to calculate $class - # during INIT phase - $MRO{$class} = undef unless exists $MRO{$class}; -} - -## initializers - -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 { - # why bother if we don't have anything ... - return unless keys %MRO; - _remove_method_dispatch_tables(); - %next::METHOD_CACHE = (); - $_initialized = 0; -} - -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, \%merge_cache); - } -} - -sub _calculate_method_dispatch_table { - my ($class, $merge_cache) = @_; - no strict 'refs'; - 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}; - $methods{$method} = { - orig => "${local}::$method", - code => \&{"${local}::$method"} - } unless exists $methods{$method}; +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!'; } - } - # now stash them in our %MRO table - $MRO{$class}->{methods} = \%methods; - $MRO{$class}->{has_overload_fallback} = $has_overload_fallback; -} - -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'; - ${"${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 - -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; - } - - 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; - }; - - 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__ diff --git a/lib/Class/C3/PurePerl.pm b/lib/Class/C3/PurePerl.pm new file mode 100644 index 0000000..c05f8f2 --- /dev/null +++ b/lib/Class/C3/PurePerl.pm @@ -0,0 +1,253 @@ + +package Class::C3::PurePerl; + +our $VERSION = '0.15'; + +=pod + +=head1 NAME + +Class::C3::PurePerl - The default pure-Perl implementation of Class::C3 + +=head1 DESCRIPTION + +This is the plain pure-Perl implementation of Class::C3. The main Class::C3 package will +first attempt to load L, and then failing that, will fall back to this. Do +not use this package directly, use L instead. + +=head1 AUTHOR + +Stevan Little, Estevan@iinteractive.comE + +Brandon L. Black, Eblblack@gmail.comE + +=head1 COPYRIGHT AND LICENSE + +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 + +package # hide me from PAUSE + Class::C3; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; +use Algorithm::C3; + +# this is our global stash of both +# MRO's and method dispatch tables +# the structure basically looks like +# this: +# +# $MRO{$class} = { +# MRO => [ ], +# methods => { +# orig => , +# code => \& +# }, +# has_overload_fallback => (1 | 0) +# } +# +our %MRO; + +# 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; + # make a note to calculate $class + # during INIT phase + $MRO{$class} = undef unless exists $MRO{$class}; +} + +## initializers + +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 { + # why bother if we don't have anything ... + return unless keys %MRO; + _remove_method_dispatch_tables(); + %next::METHOD_CACHE = (); + $_initialized = 0; +} + +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, \%merge_cache); + } +} + +sub _calculate_method_dispatch_table { + my ($class, $merge_cache) = @_; + no strict 'refs'; + 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}; + $methods{$method} = { + orig => "${local}::$method", + code => \&{"${local}::$method"} + } unless exists $methods{$method}; + } + } + # now stash them in our %MRO table + $MRO{$class}->{methods} = \%methods; + $MRO{$class}->{has_overload_fallback} = $has_overload_fallback; +} + +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'; + ${"${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 + +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; + +our $VERSION = 0.15; + +use Scalar::Util 'blessed'; + +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; + } + + 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; + }; + + 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.15; + +sub method { (next::method($_[0]) || return)->(@_) } + +1;