#line 1 package MRO::Compat; use strict; use warnings; require 5.006_000; # Keep this < 1.00, so people can tell the fake # mro.pm from the real one our $VERSION = '0.11'; BEGIN { # Alias our private functions over to # the mro:: namespace and load # Class::C3 if Perl < 5.9.5 if($] < 5.009_005) { $mro::VERSION # to fool Module::Install when generating META.yml = $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::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 }; } } #line 113 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'"; } #line 154 sub __import { if($_[1]) { goto &Class::C3::import if $_[1] eq 'c3'; __set_mro(scalar(caller), $_[1]); } } #line 169 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') { # 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}; } else { die qq{Invalid mro type "$type"}; } return; } #line 203 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'; } #line 222 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; # 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 { my $classname = shift; die "mro::get_isarev requires a classname" if !defined $classname; __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0); } #line 298 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; } #line 321 sub __invalidate_all_method_caches { # Super secret mystery code :) @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA; return; } #line 342 sub __method_changed_in { my $classname = shift; die "mro::method_changed_in requires a classname" if !defined $classname; __invalidate_all_method_caches(); } #line 358 { 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++; } } sub __get_pkg_gen_c3xs { my $classname = shift; die "mro::get_pkg_gen requires a classname" if !defined $classname; return Class::C3::XS::_plsubgen(); } #line 407 1;