Skip to content

Instantly share code, notes, and snippets.

@hideo55
Created November 27, 2010 12:28
Show Gist options
  • Save hideo55/717853 to your computer and use it in GitHub Desktop.
Save hideo55/717853 to your computer and use it in GitHub Desktop.
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;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment