package MRO::Compat;
use strict;
use warnings;
+require 5.006_000;
-our $VERSION = '0.01';
-
-# Is Class::C3 installed locally?
-our $C3_INSTALLED;
+# Keep this < 1.00, so people can tell the fake
+# mro.pm from the real one
+our $VERSION = '0.02';
BEGIN {
- # Don't do anything if 5.9.5+
+ # Alias our private functions over to
+ # the mro:: namespace and load
+ # Class::C3 if Perl < 5.9.5
if($] < 5.009_005) {
- # Find out if we have Class::C3 at all
- eval { require Class::C3 };
- $C3_INSTALLED = 1 if !$@;
-
- # Alias our private functions over to
- # the mro:: namespace
+ $mro::VERSION = $VERSION;
+ $INC{'mro.pm'} = 'Faked by MRO::Compat';
*mro::import = \&__import;
*mro::get_linear_isa = \&__get_linear_isa;
*mro::set_mro = \&__set_mro;
*mro::method_changed_in = \&__method_changed_in;
*mro::invalidate_all_method_caches
= \&__invalidate_all_method_caches;
+ require Class::C3;
+ if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
+ *mro::get_pkg_gen = \&__get_pkg_gen_c3xs;
+ }
+ else {
+ *mro::get_pkg_gen = \&__get_pkg_gen_pp;
+ }
+ }
+
+ # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
+ else {
+ require mro;
+ no warnings 'redefine';
+ *Class::C3::initialize = sub { 1 };
+ *Class::C3::reinitialize = sub { 1 };
+ *Class::C3::uninitialize = sub { 1 };
}
}
=head1 NAME
-MRO::Compat - Partial mro::* interface compatibility for Perls < 5.9.5
+MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
=head1 SYNOPSIS
with method resolution order and method caching in general
in Perl 5.9.5 and higher.
-This module provides a subset of those interfaces for
-earlier versions of Perl. It is a harmless no-op to use
-it on 5.9.5+. If you're writing a piece of software
-that would like to use the parts of 5.9.5+'s mro::
-interfaces that are supported here, and you want
-compatibility with older Perls, this is the module
-for you.
+This module provides those interfaces for
+earlier versions of Perl (back to 5.6.0 anyways).
+
+It is a harmless no-op to use this module on 5.9.5+. If
+you're writing a piece of software that would like to use
+the parts of 5.9.5+'s mro:: interfaces that are supported
+here, and you want compatibility with older Perls, this
+is the module for you.
+
+Some parts of this interface will work better with
+L<Class::C3::XS> installed, but it's not a requirement.
This module never exports any functions. All calls must
be fully qualified with the C<mro::> prefix.
+The interface documentation here serves only as a quick
+reference of what the function basically does, and what
+differences between L<MRO::Compat> and 5.9.5+ one should
+look out for. The main docs in 5.9.5's L<mro> are the real
+interface docs, and contain a lot of other useful information.
+
+=head1 VERSION 0.02
+
+This is the first release of this new module, and on top of that,
+the Perl 5.9.5 it seeks to provide compatibility with isn't even
+out yet.
+
+If you're going to use/depend on this, please keep abreast of
+possible interface changes in the next few versions. Once Perl
+5.9.5 is out the door the interfaces should stabilize on whatever
+5.9.5 has to offer. In the meantime, don't be surprised if
+L<MRO::Compat> and 5.9.5's interfaces aren't perfectly in sync
+at all times.
+
=head1 Functions
=head2 mro::get_linear_isa($classname[, $type])
on the given class, starting with itself. It does not include any
duplicate entries.
-On pre-5.9.5 Perls with MRO::Compat, explicitly asking for the C<c3>
-MRO of a class will die if L<Class::C3> is not installed. If
-L<Class::C3> is installed, it will detect C3 classes and return the
-correct C3 MRO unless explicitly asked to return the C<dfs> MRO.
-
Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
part of the MRO of a class, even though all classes implicitly inherit
methods from C<UNIVERSAL> and its parents.
=cut
+sub __get_linear_isa_dfs {
+ no strict 'refs';
+
+ my $classname = shift;
+
+ my @lin = ($classname);
+ my %stored;
+ foreach my $parent (@{"$classname\::ISA"}) {
+ my $plin = __get_linear_isa_dfs($parent);
+ foreach (@$plin) {
+ next if exists $stored{$_};
+ push(@lin, $_);
+ $stored{$_} = 1;
+ }
+ }
+ return \@lin;
+}
+
sub __get_linear_isa {
+ my ($classname, $type) = @_;
+ die "mro::get_mro requires a classname" if !$classname;
+
+ $type ||= __get_mro($classname);
+ if($type eq 'dfs') {
+ return __get_linear_isa_dfs($classname);
+ }
+ elsif($type eq 'c3') {
+ return [Class::C3::calculateMRO($classname)];
+ }
+ die "type argument must be 'dfs' or 'c3'";
}
=head2 mro::import
-Not supported, and hence 5.9.5's "use mro 'foo'" is also not supported.
-These will die if used on pre-5.9.5 Perls.
+This allows the C<use mro 'dfs'> and
+C<use mro 'c3'> syntaxes, providing you
+L<use MRO::Compat> first. Please see the
+L</USING C3> section for additional details.
=cut
sub __import {
- die q{The "use mro 'foo'" is only supported on Perl 5.9.5+};
+ if($_[1]) {
+ goto &Class::C3::import if $_[1] eq 'c3';
+ __set_mro(scalar(caller), $_[1]);
+ }
}
=head2 mro::set_mro($classname, $type)
-Not supported, will die if used on pre-5.9.5 Perls.
+Sets the mro of C<$classname> to one of the types
+C<dfs> or C<c3>. Please see the L</USING C3>
+section for additional details.
=cut
sub __set_mro {
- die q{mro::set_mro() is only supported on Perl 5.9.5+};
+ my ($classname, $type) = @_;
+ if(!$classname || !$type) {
+ die q{Usage: mro::set_mro($classname, $type)};
+ }
+ if($type eq 'c3') {
+ eval "package $classname; use Class::C3";
+ die $@ if $@;
+ }
+ if($type ne 'dfs') {
+ die q{Invalid mro type "$type"};
+ }
+
+ # In the dfs case, check whether we need to undo C3
+ if(defined $Class::C3::MRO{$classname}) {
+ Class::C3::_remove_method_dispatch_table($classname);
+ }
+ delete $Class::C3::MRO{$classname};
+
+ return;
}
=head2 mro::get_mro($classname)
Returns the MRO of the given class (either C<c3> or C<dfs>).
+It considers any Class::C3-using class to have C3 MRO
+even before L<Class::C3::initialize()> is called.
+
=cut
sub __get_mro {
- my $classname = shift
+ my $classname = shift;
die "mro::get_mro requires a classname" if !$classname;
- if($C3_INSTALLED && exists $Class::C3::MRO{$classname}
- && $Class::C3::_initialized) {
- return 'c3';
- }
+ return 'c3' if exists $Class::C3::MRO{$classname};
return 'dfs';
}
=head2 mro::get_isarev($classname)
-Not supported, will die if used on pre-5.9.5 Perls.
+Returns an arrayref of classes who are subclasses of the
+given classname. In other words, classes who we exist,
+however indirectly, in the @ISA inheritancy hierarchy of.
+
+This is much slower on pre-5.9.5 Perls with MRO::Compat
+than it is on 5.9.5+, as it has to search the entire
+package namespace.
=cut
+sub __get_all_pkgs_with_isas {
+ no strict 'refs';
+ no warnings 'recursion';
+
+ my @retval;
+
+ my $search = shift;
+ my $pfx;
+ my $isa;
+ if($search) {
+ $isa = \@{"$search\::ISA"};
+ $pfx = "$search\::";
+ }
+ else {
+ $search = 'main';
+ $isa = \@main::ISA;
+ $pfx = '';
+ }
+
+ push(@retval, $search) if scalar(@$isa);
+
+ foreach my $cand (keys %{"$search\::"}) {
+ if($cand =~ /::$/) {
+ $cand =~ s/::$//;
+ next if $cand eq $search; # skip self-reference (main?)
+ push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
+ }
+ }
+
+ return \@retval;
+}
+
+sub __get_isarev_recurse {
+ no strict 'refs';
+
+ my ($class, $all_isas, $level) = @_;
+
+ die "Recursive inheritance detected" if $level > 100;
+
+ my %retval;
+
+ foreach my $cand (@$all_isas) {
+ my $found_me;
+ foreach (@{"$cand\::ISA"}) {
+ if($_ eq $class) {
+ $found_me = 1;
+ last;
+ }
+ }
+ if($found_me) {
+ $retval{$cand} = 1;
+ map { $retval{$_} = 1 }
+ @{__get_isarev_recurse($cand, $all_isas, $level+1)};
+ }
+ }
+ return [keys %retval];
+}
+
sub __get_isarev {
- die "mro::get_isarev() is only supported on Perl 5.9.5+";
+ my $classname = shift;
+ die "mro::get_isarev requires a classname" if !$classname;
+
+ __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
}
=head2 mro::is_universal($classname)
my $classname = shift;
die "mro::is_universal requires a classname" if !$classname;
- my $lin = __get_linear_isa($classname);
+ my $lin = __get_linear_isa('UNIVERSAL');
foreach (@$lin) {
return 1 if $classname eq $_;
}
Increments C<PL_sub_generation>, which invalidates method
caching in all packages.
+Please note that this is rarely necessary, unless you are
+dealing with a situation which is known to confuse Perl's
+method caching.
+
=cut
sub __invalidate_all_method_caches {
enforce the requirement that you pass it a classname, for
compatibility.
+Please note that this is rarely necessary, unless you are
+dealing with a situation which is known to confuse Perl's
+method caching.
+
=cut
sub __method_changed_in {
__invalidate_all_method_caches();
}
+=head2 mro::get_pkg_gen($classname)
+
+Returns an integer which is incremented every time a local
+method of or the C<@ISA> of the given package changes on
+Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module,
+it will probably increment a lot more often than necessary.
+
+=cut
+
+my $__pkg_gen = 2;
+sub __get_pkg_gen_pp {
+ my $classname = shift;
+ die "mro::get_pkg_gen requires a classname" if !$classname;
+ return $__pkg_gen++;
+}
+
+sub __get_pkg_gen_c3xs {
+ my $classname = shift;
+ die "mro::get_pkg_gen requires a classname" if !$classname;
+
+ return Class::C3::XS::_plsubgen();
+}
+
+=head1 USING C3
+
+While this module makes the 5.9.5+ syntaxes
+C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
+on older Perls, it does so merely by passing off the work
+to L<Class::C3>.
+
+It does not remove the need for you to call
+L<Class::C3>'s C<initialize()>, C<reinitialize()>, and/or
+C<uninitialize()> at the appropriate times
+as documented in the L<Class::C3> docs.
+
+Because L<MRO::Compat> has L<Class::C3> as a pre-requisite,
+and requires it at C<use> time, you can blindly call
+those functions in code that uses L<MRO::Compat>.
+Under 5.9.5+ with L<MRO::Compat>, your calls to those
+functions will become a no-op and everything will work fine.
+
=head1 SEE ALSO
L<Class::C3>
projects / gitmo/MRO-Compat.git / blobdiff