Blame lib/MRO/Compat.pm

Packit 4c8e34
package MRO::Compat;
Packit 4c8e34
use strict;
Packit 4c8e34
use warnings;
Packit 4c8e34
require 5.006_000;
Packit 4c8e34
Packit 4c8e34
# Keep this < 1.00, so people can tell the fake
Packit 4c8e34
#  mro.pm from the real one
Packit 4c8e34
our $VERSION = '0.13';
Packit 4c8e34
Packit 4c8e34
BEGIN {
Packit 4c8e34
    # Alias our private functions over to
Packit 4c8e34
    # the mro:: namespace and load
Packit 4c8e34
    # Class::C3 if Perl < 5.9.5
Packit 4c8e34
    if($] < 5.009_005) {
Packit 4c8e34
        $mro::VERSION # to fool Module::Install when generating META.yml
Packit 4c8e34
            = $VERSION;
Packit 4c8e34
        $INC{'mro.pm'} = __FILE__;
Packit 4c8e34
        *mro::import            = \&__import;
Packit 4c8e34
        *mro::get_linear_isa    = \&__get_linear_isa;
Packit 4c8e34
        *mro::set_mro           = \&__set_mro;
Packit 4c8e34
        *mro::get_mro           = \&__get_mro;
Packit 4c8e34
        *mro::get_isarev        = \&__get_isarev;
Packit 4c8e34
        *mro::is_universal      = \&__is_universal;
Packit 4c8e34
        *mro::method_changed_in = \&__method_changed_in;
Packit 4c8e34
        *mro::invalidate_all_method_caches
Packit 4c8e34
                                = \&__invalidate_all_method_caches;
Packit 4c8e34
        require Class::C3;
Packit 4c8e34
        if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
Packit 4c8e34
            *mro::get_pkg_gen   = \&__get_pkg_gen_c3xs;
Packit 4c8e34
        }
Packit 4c8e34
        else {
Packit 4c8e34
            *mro::get_pkg_gen   = \&__get_pkg_gen_pp;
Packit 4c8e34
        }
Packit 4c8e34
    }
Packit 4c8e34
Packit 4c8e34
    # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
Packit 4c8e34
    else {
Packit 4c8e34
        require mro;
Packit 4c8e34
        no warnings 'redefine';
Packit 4c8e34
        *Class::C3::initialize = sub { 1 };
Packit 4c8e34
        *Class::C3::reinitialize = sub { 1 };
Packit 4c8e34
        *Class::C3::uninitialize = sub { 1 };
Packit 4c8e34
    }
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head1 NAME
Packit 4c8e34
Packit 4c8e34
MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
Packit 4c8e34
Packit 4c8e34
=head1 SYNOPSIS
Packit 4c8e34
Packit 4c8e34
   package PPP;      use base qw/Exporter/;
Packit 4c8e34
   package X;        use base qw/PPP/;
Packit 4c8e34
   package Y;        use base qw/PPP/;
Packit 4c8e34
   package Z;        use base qw/PPP/;
Packit 4c8e34
Packit 4c8e34
   package FooClass; use base qw/X Y Z/;
Packit 4c8e34
Packit 4c8e34
   package main;
Packit 4c8e34
   use MRO::Compat;
Packit 4c8e34
   my $linear = mro::get_linear_isa('FooClass');
Packit 4c8e34
   print join(q{, }, @$linear);
Packit 4c8e34
Packit 4c8e34
   # Prints: FooClass, X, PPP, Exporter, Y, Z
Packit 4c8e34
Packit 4c8e34
=head1 DESCRIPTION
Packit 4c8e34
Packit 4c8e34
The "mro" namespace provides several utilities for dealing
Packit 4c8e34
with method resolution order and method caching in general
Packit 4c8e34
in Perl 5.9.5 and higher.
Packit 4c8e34
Packit 4c8e34
This module provides those interfaces for
Packit 4c8e34
earlier versions of Perl (back to 5.6.0 anyways).
Packit 4c8e34
Packit 4c8e34
It is a harmless no-op to use this module on 5.9.5+.  That
Packit 4c8e34
is to say, code which properly uses L<MRO::Compat> will work
Packit 4c8e34
unmodified on both older Perls and 5.9.5+.
Packit 4c8e34
Packit 4c8e34
If you're writing a piece of software that would like to use
Packit 4c8e34
the parts of 5.9.5+'s mro:: interfaces that are supported
Packit 4c8e34
here, and you want compatibility with older Perls, this
Packit 4c8e34
is the module for you.
Packit 4c8e34
Packit 4c8e34
Some parts of this code will work better and/or faster with
Packit 4c8e34
L<Class::C3::XS> installed (which is an optional prereq
Packit 4c8e34
of L<Class::C3>, which is in turn a prereq of this
Packit 4c8e34
package), but it's not a requirement.
Packit 4c8e34
Packit 4c8e34
This module never exports any functions.  All calls must
Packit 4c8e34
be fully qualified with the C<mro::> prefix.
Packit 4c8e34
Packit 4c8e34
The interface documentation here serves only as a quick
Packit 4c8e34
reference of what the function basically does, and what
Packit 4c8e34
differences between L<MRO::Compat> and 5.9.5+ one should
Packit 4c8e34
look out for.  The main docs in 5.9.5's L<mro> are the real
Packit 4c8e34
interface docs, and contain a lot of other useful information.
Packit 4c8e34
Packit 4c8e34
=head1 Functions
Packit 4c8e34
Packit 4c8e34
=head2 mro::get_linear_isa($classname[, $type])
Packit 4c8e34
Packit 4c8e34
Returns an arrayref which is the linearized "ISA" of the given class.
Packit 4c8e34
Uses whichever MRO is currently in effect for that class by default,
Packit 4c8e34
or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
Packit 4c8e34
Packit 4c8e34
The linearized ISA of a class is a single ordered list of all of the
Packit 4c8e34
classes that would be visited in the process of resolving a method
Packit 4c8e34
on the given class, starting with itself.  It does not include any
Packit 4c8e34
duplicate entries.
Packit 4c8e34
Packit 4c8e34
Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
Packit 4c8e34
part of the MRO of a class, even though all classes implicitly inherit
Packit 4c8e34
methods from C<UNIVERSAL> and its parents.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __get_linear_isa_dfs {
Packit 4c8e34
    no strict 'refs';
Packit 4c8e34
Packit 4c8e34
    my $classname = shift;
Packit 4c8e34
Packit 4c8e34
    my @lin = ($classname);
Packit 4c8e34
    my %stored;
Packit 4c8e34
    foreach my $parent (@{"$classname\::ISA"}) {
Packit 4c8e34
        my $plin = __get_linear_isa_dfs($parent);
Packit 4c8e34
        foreach (@$plin) {
Packit 4c8e34
            next if exists $stored{$_};
Packit 4c8e34
            push(@lin, $_);
Packit 4c8e34
            $stored{$_} = 1;
Packit 4c8e34
        }
Packit 4c8e34
    }
Packit 4c8e34
    return \@lin;
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
sub __get_linear_isa {
Packit 4c8e34
    my ($classname, $type) = @_;
Packit 4c8e34
    die "mro::get_mro requires a classname" if !defined $classname;
Packit 4c8e34
Packit 4c8e34
    $type ||= __get_mro($classname);
Packit 4c8e34
    if($type eq 'dfs') {
Packit 4c8e34
        return __get_linear_isa_dfs($classname);
Packit 4c8e34
    }
Packit 4c8e34
    elsif($type eq 'c3') {
Packit 4c8e34
        return [Class::C3::calculateMRO($classname)];
Packit 4c8e34
    }
Packit 4c8e34
    die "type argument must be 'dfs' or 'c3'";
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::import
Packit 4c8e34
Packit 4c8e34
This allows the C<use mro 'dfs'> and
Packit 4c8e34
C<use mro 'c3'> syntaxes, providing you
Packit 4c8e34
L<use MRO::Compat> first.  Please see the
Packit 4c8e34
L</USING C3> section for additional details.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __import {
Packit 4c8e34
    if($_[1]) {
Packit 4c8e34
        goto &Class::C3::import if $_[1] eq 'c3';
Packit 4c8e34
        __set_mro(scalar(caller), $_[1]);
Packit 4c8e34
    }
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::set_mro($classname, $type)
Packit 4c8e34
Packit 4c8e34
Sets the mro of C<$classname> to one of the types
Packit 4c8e34
C<dfs> or C<c3>.  Please see the L</USING C3>
Packit 4c8e34
section for additional details.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __set_mro {
Packit 4c8e34
    my ($classname, $type) = @_;
Packit 4c8e34
Packit 4c8e34
    if(!defined $classname || !$type) {
Packit 4c8e34
        die q{Usage: mro::set_mro($classname, $type)};
Packit 4c8e34
    }
Packit 4c8e34
Packit 4c8e34
    if($type eq 'c3') {
Packit 4c8e34
        eval "package $classname; use Class::C3";
Packit 4c8e34
        die $@ if $@;
Packit 4c8e34
    }
Packit 4c8e34
    elsif($type eq 'dfs') {
Packit 4c8e34
        # In the dfs case, check whether we need to undo C3
Packit 4c8e34
        if(defined $Class::C3::MRO{$classname}) {
Packit 4c8e34
            Class::C3::_remove_method_dispatch_table($classname);
Packit 4c8e34
        }
Packit 4c8e34
        delete $Class::C3::MRO{$classname};
Packit 4c8e34
    }
Packit 4c8e34
    else {
Packit 4c8e34
        die qq{Invalid mro type "$type"};
Packit 4c8e34
    }
Packit 4c8e34
Packit 4c8e34
    return;
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::get_mro($classname)
Packit 4c8e34
Packit 4c8e34
Returns the MRO of the given class (either C<c3> or C<dfs>).
Packit 4c8e34
Packit 4c8e34
It considers any Class::C3-using class to have C3 MRO
Packit 4c8e34
even before L<Class::C3::initialize()> is called.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __get_mro {
Packit 4c8e34
    my $classname = shift;
Packit 4c8e34
    die "mro::get_mro requires a classname" if !defined $classname;
Packit 4c8e34
    return 'c3' if exists $Class::C3::MRO{$classname};
Packit 4c8e34
    return 'dfs';
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::get_isarev($classname)
Packit 4c8e34
Packit 4c8e34
Returns an arrayref of classes who are subclasses of the
Packit 4c8e34
given classname.  In other words, classes in whose @ISA
Packit 4c8e34
hierarchy we appear, no matter how indirectly.
Packit 4c8e34
Packit 4c8e34
This is much slower on pre-5.9.5 Perls with MRO::Compat
Packit 4c8e34
than it is on 5.9.5+, as it has to search the entire
Packit 4c8e34
package namespace.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __get_all_pkgs_with_isas {
Packit 4c8e34
    no strict 'refs';
Packit 4c8e34
    no warnings 'recursion';
Packit 4c8e34
Packit 4c8e34
    my @retval;
Packit 4c8e34
Packit 4c8e34
    my $search = shift;
Packit 4c8e34
    my $pfx;
Packit 4c8e34
    my $isa;
Packit 4c8e34
    if(defined $search) {
Packit 4c8e34
        $isa = \@{"$search\::ISA"};
Packit 4c8e34
        $pfx = "$search\::";
Packit 4c8e34
    }
Packit 4c8e34
    else {
Packit 4c8e34
        $search = 'main';
Packit 4c8e34
        $isa = \@main::ISA;
Packit 4c8e34
        $pfx = '';
Packit 4c8e34
    }
Packit 4c8e34
Packit 4c8e34
    push(@retval, $search) if scalar(@$isa);
Packit 4c8e34
Packit 4c8e34
    foreach my $cand (keys %{"$search\::"}) {
Packit 4c8e34
        if($cand =~ s/::$//) {
Packit 4c8e34
            next if $cand eq $search; # skip self-reference (main?)
Packit 4c8e34
            push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
Packit 4c8e34
        }
Packit 4c8e34
    }
Packit 4c8e34
Packit 4c8e34
    return \@retval;
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
sub __get_isarev_recurse {
Packit 4c8e34
    no strict 'refs';
Packit 4c8e34
Packit 4c8e34
    my ($class, $all_isas, $level) = @_;
Packit 4c8e34
Packit 4c8e34
    die "Recursive inheritance detected" if $level > 100;
Packit 4c8e34
Packit 4c8e34
    my %retval;
Packit 4c8e34
Packit 4c8e34
    foreach my $cand (@$all_isas) {
Packit 4c8e34
        my $found_me;
Packit 4c8e34
        foreach (@{"$cand\::ISA"}) {
Packit 4c8e34
            if($_ eq $class) {
Packit 4c8e34
                $found_me = 1;
Packit 4c8e34
                last;
Packit 4c8e34
            }
Packit 4c8e34
        }
Packit 4c8e34
        if($found_me) {
Packit 4c8e34
            $retval{$cand} = 1;
Packit 4c8e34
            map { $retval{$_} = 1 }
Packit 4c8e34
                @{__get_isarev_recurse($cand, $all_isas, $level+1)};
Packit 4c8e34
        }
Packit 4c8e34
    }
Packit 4c8e34
    return [keys %retval];
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
sub __get_isarev {
Packit 4c8e34
    my $classname = shift;
Packit 4c8e34
    die "mro::get_isarev requires a classname" if !defined $classname;
Packit 4c8e34
Packit 4c8e34
    __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::is_universal($classname)
Packit 4c8e34
Packit 4c8e34
Returns a boolean status indicating whether or not
Packit 4c8e34
the given classname is either C<UNIVERSAL> itself,
Packit 4c8e34
or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
Packit 4c8e34
Packit 4c8e34
Any class for which this function returns true is
Packit 4c8e34
"universal" in the sense that all classes potentially
Packit 4c8e34
inherit methods from it.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __is_universal {
Packit 4c8e34
    my $classname = shift;
Packit 4c8e34
    die "mro::is_universal requires a classname" if !defined $classname;
Packit 4c8e34
Packit 4c8e34
    my $lin = __get_linear_isa('UNIVERSAL');
Packit 4c8e34
    foreach (@$lin) {
Packit 4c8e34
        return 1 if $classname eq $_;
Packit 4c8e34
    }
Packit 4c8e34
Packit 4c8e34
    return 0;
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::invalidate_all_method_caches
Packit 4c8e34
Packit 4c8e34
Increments C<PL_sub_generation>, which invalidates method
Packit 4c8e34
caching in all packages.
Packit 4c8e34
Packit 4c8e34
Please note that this is rarely necessary, unless you are
Packit 4c8e34
dealing with a situation which is known to confuse Perl's
Packit 4c8e34
method caching.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __invalidate_all_method_caches {
Packit 4c8e34
    # Super secret mystery code :)
Packit 4c8e34
    @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
Packit 4c8e34
    return;
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::method_changed_in($classname)
Packit 4c8e34
Packit 4c8e34
Invalidates the method cache of any classes dependent on the
Packit 4c8e34
given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
Packit 4c8e34
an alias for C<mro::invalidate_all_method_caches> above, as
Packit 4c8e34
pre-5.9.5 Perls have no other way to do this.  It will still
Packit 4c8e34
enforce the requirement that you pass it a classname, for
Packit 4c8e34
compatibility.
Packit 4c8e34
Packit 4c8e34
Please note that this is rarely necessary, unless you are
Packit 4c8e34
dealing with a situation which is known to confuse Perl's
Packit 4c8e34
method caching.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
sub __method_changed_in {
Packit 4c8e34
    my $classname = shift;
Packit 4c8e34
    die "mro::method_changed_in requires a classname" if !defined $classname;
Packit 4c8e34
Packit 4c8e34
    __invalidate_all_method_caches();
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head2 mro::get_pkg_gen($classname)
Packit 4c8e34
Packit 4c8e34
Returns an integer which is incremented every time a local
Packit 4c8e34
method of or the C<@ISA> of the given package changes on
Packit 4c8e34
Perl 5.9.5+.  On earlier Perls with this L<MRO::Compat> module,
Packit 4c8e34
it will probably increment a lot more often than necessary.
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
{
Packit 4c8e34
    my $__pkg_gen = 2;
Packit 4c8e34
    sub __get_pkg_gen_pp {
Packit 4c8e34
        my $classname = shift;
Packit 4c8e34
        die "mro::get_pkg_gen requires a classname" if !defined $classname;
Packit 4c8e34
        return $__pkg_gen++;
Packit 4c8e34
    }
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
sub __get_pkg_gen_c3xs {
Packit 4c8e34
    my $classname = shift;
Packit 4c8e34
    die "mro::get_pkg_gen requires a classname" if !defined $classname;
Packit 4c8e34
Packit 4c8e34
    return Class::C3::XS::_plsubgen();
Packit 4c8e34
}
Packit 4c8e34
Packit 4c8e34
=head1 USING C3
Packit 4c8e34
Packit 4c8e34
While this module makes the 5.9.5+ syntaxes
Packit 4c8e34
C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
Packit 4c8e34
on older Perls, it does so merely by passing off the work
Packit 4c8e34
to L<Class::C3>.
Packit 4c8e34
Packit 4c8e34
It does not remove the need for you to call
Packit 4c8e34
C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
Packit 4c8e34
C<Class::C3::uninitialize()> at the appropriate times
Packit 4c8e34
as documented in the L<Class::C3> docs.  These three functions
Packit 4c8e34
are always provided by L<MRO::Compat>, either via L<Class::C3>
Packit 4c8e34
itself on older Perls, or directly as no-ops on 5.9.5+.
Packit 4c8e34
Packit 4c8e34
=head1 SEE ALSO
Packit 4c8e34
Packit 4c8e34
L<Class::C3>
Packit 4c8e34
Packit 4c8e34
L<mro>
Packit 4c8e34
Packit 4c8e34
=head1 AUTHOR
Packit 4c8e34
Packit 4c8e34
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
Packit 4c8e34
Packit 4c8e34
=head1 COPYRIGHT AND LICENSE
Packit 4c8e34
Packit 4c8e34
Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
Packit 4c8e34
Packit 4c8e34
This library is free software; you can redistribute it and/or modify
Packit 4c8e34
it under the same terms as Perl itself. 
Packit 4c8e34
Packit 4c8e34
=cut
Packit 4c8e34
Packit 4c8e34
1;