mro.pm

package mro;

package MRO::Compat;
use strict;
use warnings;
require 5.006_000;

our $VERSION = '0.11';

BEGIN {
    $mro::VERSION= $VERSION;
    $INC{'mro.pm'} = __FILE__;
    *mro::import                       = ¥&__import;
    *mro::get_linear_isa               = ¥&__get_linear_isa;
    *mro::set_mro                      = ¥&__set_mro;
    *mro::get_mro                      = ¥&__get_mro;
    *mro::get_isarev                   = ¥&__get_isarev;
    *mro::is_universal                 = ¥&__is_universal;
    *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;
    }

}

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 !defined $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'";
}

sub __import {
    if ( $_[1] ) {
        goto &Class::C3::import if $_[1] eq 'c3';
        __set_mro( scalar(caller), $_[1] );
    }
}

sub __set_mro {
    my ( $classname, $type ) = @_;

    if ( !defined $classname || !$type ) {
        die q{Usage: mro::set_mro($classname, $type)};
    }

    if ( $type eq 'c3' ) {
        eval "package $classname; use Class::C3";
        die $@ if $@;
    }
    elsif ( $type eq 'dfs' ) {

        if ( defined $Class::C3::MRO{$classname} ) {
            Class::C3::_remove_method_dispatch_table($classname);
        }
        delete $Class::C3::MRO{$classname};
    }
    else {
        die qq{Invalid mro type "$type"};
    }

    return;
}

sub __get_mro {
    my $classname = shift;
    die "mro::get_mro requires a classname" if !defined $classname;
    return 'c3' if exists $Class::C3::MRO{$classname};
    return 'dfs';
}

sub __get_all_pkgs_with_isas {
    no strict 'refs';
    no warnings 'recursion';

    my @retval;

    my $search = shift;
    my $pfx;
    my $isa;
    if ( defined $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 =~ s/::$// ) {
            next if $cand eq $search;
            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 {
    my $classname = shift;
    die "mro::get_isarev requires a classname" if !defined $classname;

    __get_isarev_recurse( $classname, __get_all_pkgs_with_isas(), 0 );
}

sub __is_universal {
    my $classname = shift;
    die "mro::is_universal requires a classname" if !defined $classname;

    my $lin = __get_linear_isa('UNIVERSAL');
    foreach (@$lin) {
        return 1 if $classname eq $_;
    }

    return 0;
}

sub __invalidate_all_method_caches {
    @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
    return;
}

{
    my $__pkg_gen = 2;

    sub __get_pkg_gen_pp {
        my $classname = shift;
        die "mro::get_pkg_gen requires a classname" if !defined $classname;
        return $__pkg_gen++;
    }
}

1;