File Coverage

blib/lib/Devel/Isa/Explainer/_MRO.pm

Criterion	Covered	Total	%
statement	119	123	96.7
branch	20	24	83.3
condition	6	11	54.5
subroutine	21	22	95.4
pod	9	9	100.0
total	175	189	92.5

use 5.006;    # our
use strict;
use warnings;

package Devel::Isa::Explainer::_MRO;

# ABSTRACT: Method-resolution-order Utilities for DIE

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

our $VERSION = '0.002900'; # TRIAL

use MRO::Compat ();
use Exporter    ();
use Scalar::Util qw(reftype);

BEGIN {
  ## no critic (ProhibitCallsToUnexportedSubs)
  *import              = \&Exporter::import;
  *_mro_get_linear_isa = \&mro::get_linear_isa;
  *_mro_is_universal   = \&mro::is_universal;
}

# yes, this is evil

our @EXPORT_OK = qw(
  is_mro_proxy
  get_linear_isa
  get_package_sub
  get_package_subs
  get_linear_class_shadows
  get_parents
  get_linear_method_map
  get_linear_class_map
  get_flattened_class
);

BEGIN {
  # MRO Proxies removed since 5.009_005
  *MRO_PROXIES = ( $] <= 5.009005 ) ? sub() { 1 } : sub() { 0 };
}

use namespace::clean -except => 'import';

















sub is_mro_proxy {

  # Note: this sub should be optimised out from calling anyway
  # but this is just a failsafe
  MRO_PROXIES ? !!( $Class::C3::MRO{ $_[0] } || {} )->{methods}{ $_[1] } : 0;
}

















sub get_linear_isa {
  [
    @{ _mro_get_linear_isa( $_[0] ) },
    #<<<
    _mro_is_universal( $_[0] )
      ? ()
      : @{ _mro_get_linear_isa('UNIVERSAL') },
    #>>>
  ];
}














sub get_package_sub {
  return undef if MRO_PROXIES and is_mro_proxy(@_);
  my ( $package, $sub ) = @_;

  # this is counter intuitive, but literally
  # everything in a stash that is not a glob *is* a sub.
  #
  # Though they're usually constant-subs.
  #
  # Globs however can /contain/ subs in their {CODE} slot,
  # but globs are not subs.
  my $namespace = do {
    no strict 'refs';
    \%{"${package}::"};
  };
  return undef unless exists $namespace->{$sub};
  if ( 'GLOB' eq reftype \$namespace->{$sub} ) {

    # Autoviv guard.
    return defined *{ \$namespace->{$sub} }{'CODE'} ? *{ \$namespace->{$sub} }{'CODE'} : undef;
  }

  # Note: This vivifies the stash slot into a glob...
  # there's not much that can be done about this at present.
  # Package::Stash does the same.
  #
  # This means the first of us or Package::Stash to traverse a symtable turns
  # everything into globs in order to get coderefs out.
  #
  # Ideally, we don't do this, but ENEEDINFO
  return \&{"${package}::${sub}"};
}











# like get_package_sub, but does a whole class at once and returns a hashref
# of { name => CODEREF }
sub get_package_subs {
  my ($package)   = @_;
  my ($namespace) = do {
    no strict 'refs';
    \%{"${package}::"};
  };
  my (@symnames) = do {
    no strict 'refs';
    keys %{"${package}::"};
  };
  my $subs = {};
  for my $symname (@symnames) {

    my $reftype = reftype \$namespace->{$symname};

    # Globs are only subs if they contain a CODE slot
    # all non-globs vivify to subs.
    # Order can't be changed though, because the second test requires the
    # first to be true to test, so defined is only tested when eq.
    next if ( 'GLOB' eq $reftype ) and not defined *{ \$namespace->{$symname} }{'CODE'};
    next if MRO_PROXIES and is_mro_proxy( $package, $symname );
    $subs->{$symname} =
      'GLOB' eq $reftype
      ? *{ \$namespace->{$symname} }{'CODE'}
      : \&{"${package}::${symname}"};
  }
  $subs;
}




















sub get_linear_class_shadows {
  my ($class) = @_;

  # Contains the "image" made bottom up
  # for comparison/detecting shadows.
  my $methods = {};
  my @isa_out;
  for my $package ( reverse @{ get_linear_isa($class) } ) {
    my $subs = get_package_subs($package);
    my $node = {};
    for my $subname ( keys %{$subs} ) {

      # first node is never shadowing
      if ( not exists $methods->{$subname} ) {
        $node->{$subname} = { shadowing => 0, shadowed => 0, ref => $subs->{$subname} };

        # Contains a reference to the previous incarnation
        # for later modification
        $methods->{$subname} = $node->{$subname};
        next;
      }
      $node->{$subname} = { shadowing => 1, shadowed => 0, ref => $subs->{$subname} };
      $methods->{$subname}->{shadowed} = 1;        # mark previous version shadowed
      $methods->{$subname} = $node->{$subname};    # update current
    }
    unshift @isa_out, { class => $package, subs => $node };
  }
  \@isa_out;
}


















sub get_parents {
  my ($package) = @_;
  my $namespace = do {
    no strict 'refs';
    \%{"${package}::"};
  };

  if ( exists $namespace->{ISA} ) {
    my $entry_ref = \$namespace->{ISA};
    if (  'GLOB' eq reftype $entry_ref
      and defined *{$entry_ref}{ARRAY}
      and @{ *{$entry_ref}{ARRAY} } )
    {
      return [ @{ *{$entry_ref}{ARRAY} } ];
    }
  }
  return [] if _mro_is_universal($package);
  ['UNIVERSAL'];
}














sub get_linear_method_map {
  my ( $class, $method ) = @_;
  return [ map { [ $_, get_package_sub( $_, $method ) ] } @{ get_linear_isa($class) } ];
}
















sub get_linear_class_map {
  my ($class) = @_;
  [ map { [ $_, get_package_subs($_) ] } @{ get_linear_isa($class) } ];
}




















sub get_flattened_class {
  my ($class) = @_;
  my $methods = {};
  for my $package ( reverse @{ get_linear_isa($class) } ) {
    my $subs = get_package_subs($package);
    for my $subname ( keys %{$subs} ) {
      $methods->{$subname}->{parents} ||= [];
      unshift @{ $methods->{$subname}->{parents} }, [ $methods->{$subname}->{via}, $methods->{$subname}->{ref} ]
        if exists $methods->{$subname}->{ref};
      $methods->{$subname}->{ref} = $subs->{$subname};
      $methods->{$subname}->{via} = $package;
    }
  }
  $methods;
}

1;

__END__