File Coverage

blib/lib/Devel/Isa/Explainer.pm

Criterion	Covered	Total	%
statement	147	174	84.4
branch	36	50	72.0
condition	12	14	85.7
subroutine	25	27	92.5
pod	1	1	100.0
total	221	266	83.0

use 5.006;    # our
use strict;
use warnings;

package Devel::Isa::Explainer;

our $VERSION = '0.002001';

# ABSTRACT: Pretty Print Hierarchies of Subs in Packages

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

use Exporter ();
use Term::ANSIColor 3.00 ('colored');    # bright_
use Carp           ('croak');
use Package::Stash ();
use MRO::Compat    ();

# Perl critic is broken. This is not a void context.
## no critic (BuiltinFunctions::ProhibitVoidMap)
use constant 1.03 ( { map { ( ( sprintf '_E%x', $_ ), ( sprintf ' (id: %s#%d)', __PACKAGE__, $_ ), ) } 1 .. 5 } );

use namespace::clean;

BEGIN { *import = \&Exporter::import }    ## no critic (ProhibitCallsToUnexportedSubs)

our @EXPORT_OK = qw( explain_isa );

# These exist for twiddling, but are presently undocumented as their interface
# is not deemed even remotely stable. Use at own risk.

our @TYPE_UTIL        = qw( cyan );
our @TYPE             = qw( yellow );
our @PRIVATE          = qw( reset );
our @PUBLIC           = qw( bold bright_green );
our @SHADOWED_PRIVATE = qw( magenta );
our @SHADOWED_PUBLIC  = qw( red );

our $MAX_WIDTH       = 80;
our $SHOW_SHADOWED   = 1;
our $INDENT          = q[ ] x 4;
our $SHADOW_SUFFIX   = q{(^)};
our $SHADOWED_SUFFIX = q{};                # TBD
our $CLUSTERING      = 'type_clustered';









sub explain_isa {
  my $nargs = scalar( my ( $target, ) = @_ );
  1 == $nargs     or croak "Passed $nargs arguments, Expected 1" . _E1;
  defined $target or croak 'Expected defined target' . _E2;
  length $target  or croak 'Expected target with non-zero length' . _E3;
  ref $target and croak 'Expected scalar target' . _E4;
  return _pp_key() . _pp_class($target);
}

# -- no user servicable parts --
sub _sub_type {
  my ($sub) = @_;
  return 'PRIVATE'   if $sub =~ /\A_/sx;
  return 'TYPE_UTIL' if $sub =~ /\A(is_|assert_|to_)[[:upper:]]/sx;
  return 'PRIVATE'   if $sub =~ /\A[[:upper:]][[:upper:]]/sx;
  return 'TYPE'      if $sub =~ /\A[[:upper:]]/sx;
  return 'PUBLIC';
}

sub _hl_TYPE_UTIL {
  if ( $_[0] =~ /\A([^_]+_)(.*\z)/sx ) {
    return colored( \@TYPE_UTIL, $1 ) . colored( \@TYPE, $2 );
  }
  return $_[0];
}

sub _hl_suffix {
  return colored( $_[0], $SHADOW_SUFFIX )   if $_[2];
  return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1];
  return q[];
}

sub _hl_TYPE { return colored( \@TYPE, $_[0] ) }

sub _hl_PUBLIC {
  return ( $_[1] ? colored( \@SHADOWED_PUBLIC, $_[0] ) : colored( \@PUBLIC, $_[0] ) )
    . _hl_suffix( \@SHADOWED_PUBLIC, $_[1], $_[2] );
}

sub _hl_PRIVATE {
  return ( $_[1] ? colored( \@SHADOWED_PRIVATE, $_[0] ) : colored( \@PRIVATE, $_[0] ) )
    . _hl_suffix( \@SHADOWED_PRIVATE, $_[1], $_[2] );
}

sub _pp_sub {
  return __PACKAGE__->can( '_hl_' . _sub_type( $_[0] ) )->(@_);
}

sub _pp_key {
  my @tokens;
  push @tokens, 'Public Sub: ' . _hl_PUBLIC('foo_example');
  push @tokens, 'Type Constraint: ' . _hl_TYPE('TypeName');
  push @tokens, 'Type Constraint Utility: ' . _hl_TYPE_UTIL('typeop_TypeName');
  push @tokens, 'Private/Boring Sub: ' . _hl_PRIVATE('foo_example');
  if ($SHOW_SHADOWED) {
    push @tokens, 'Public Sub shadowing another: ' . _hl_PUBLIC( 'shadowing_example', 0, 1 );
    push @tokens, 'Public Sub shadowed by higher scope: ' . _hl_PUBLIC( 'shadowed_example', 1 );
    push @tokens, 'Public Sub shadowing another and shadowed itself: ' . _hl_PUBLIC( 'shadowed_shadowing_example', 1, 1 );

    push @tokens, 'Private/Boring Sub shadowing another: ' . _hl_PRIVATE( 'shadowing_example', 0, 1 );
    push @tokens, 'Private/Boring Sub shadowed by higher scope: ' . _hl_PRIVATE( 'shadowed_example', 1 );
    push @tokens, 'Private/Boring Sub another and shadowed itself: ' . _hl_PRIVATE( 'shadowing_shadowed_example', 1, 1 );
  }
  push @tokens, 'No Subs: ()';
  return sprintf "Key:\n$INDENT%s\n\n", join qq[\n$INDENT], @tokens;
}

sub _mg_sorted {
  my (%subs) = @_;
  if ($SHOW_SHADOWED) {
    return ( [ sort { lc $a cmp lc $b } keys %subs ] );
  }
  return ( [ grep { !$subs{$_} } sort { lc $a cmp lc $b } keys %subs ] );
}

sub _mg_type_shadow_clustered {
  my (%subs) = @_;
  my %clusters;
  for my $sub ( keys %subs ) {
    my $shadow = '.shadowed' x !!$subs{$sub};
    $clusters{ _sub_type($sub) . $shadow }{$sub} = $subs{$sub};
  }
  my @out;
  for my $type ( map { ( $_, "$_.shadowed" ) } qw( PUBLIC PRIVATE TYPE TYPE_UTIL ) ) {
    next unless exists $clusters{$type};
    push @out, _mg_sorted( %{ $clusters{$type} } );
  }
  return @out;
}

sub _mg_type_clustered {
  my (%subs) = @_;
  my %clusters;
  for my $sub ( keys %subs ) {
    $clusters{ _sub_type($sub) }{$sub} = $subs{$sub};
  }
  my @out;
  for my $type (qw( PUBLIC PRIVATE TYPE TYPE_UTIL )) {
    next unless exists $clusters{$type};
    push @out, _mg_sorted( %{ $clusters{$type} } );
  }
  return @out;
}

sub _mg_aleph {
  my (%subs) = @_;
  my %clusters;
  for my $sub ( keys %subs ) {
    $clusters{ lc( substr $sub, 0, 1 ) }{$sub} = $subs{$sub};
  }
  my @out;
  for my $key ( sort keys %clusters ) {
    push @out, _mg_sorted( %{ $clusters{$key} } );
  }
  return @out;

}

sub _pp_subs {
  my (%subs)     = @_;
  my (@clusters) = __PACKAGE__->can( '_mg_' . $CLUSTERING )->(%subs);
  my (@out_clusters);
  for my $cluster (@clusters) {
    my $cluster_out = q[];

    my @subs = @{$cluster};
    while (@subs) {
      my $line = $INDENT;
    flowcontrol: {
        my $sub = shift @subs;
        $line .= $sub . q[, ];
        redo flowcontrol if @subs and length $line < $MAX_WIDTH;
      }
      $cluster_out .= "$line\n";
    }

    # Suck up trailing ,
    $cluster_out =~ s/,[ ]\n\z/\n/sx;
    $cluster_out =~ s{(\w+)}{ _pp_sub($1, $subs{$1}->{shadowed}, $subs{$1}->{shadowing} ) }gsex;
    push @out_clusters, $cluster_out;
  }
  return join qq[\n], @out_clusters;
}

sub _pp_class {
  my ($class)   = @_;
  my $out       = q[];
  my $mro_order = _extract_mro($class);
  for my $mro_entry ( @{$mro_order} ) {
    $out .= colored( ['green'], $mro_entry->{class} ) . q[:];
    my (%subs) = %{ $mro_entry->{subs} || {} };
    if ( not keys %subs ) {
      $out .= " ()\n";
      next;
    }
    else { $out .= "\n" }
    $out .= _pp_subs(%subs) . "\n";

    next;
  }
  return $out;
}

sub _extract_mro {
  my ($class)     = @_;
  my ($seen_subs) = {};

  ## no critic (ProhibitCallsToUnexportedSubs)
  my (@isa) = @{ mro::get_linear_isa($class) };

  # Discover all subs and compute full MRO every time a new sub-name
  # is found
  for my $isa (@isa) {
    for my $sub ( Package::Stash->new($isa)->list_all_symbols('CODE') ) {
      next if exists $seen_subs->{$sub};

      # Compute the full sub->package MRO table bottom up

      $seen_subs->{$sub} = [];
      my $currently_visible;
      for my $class ( reverse @isa ) {
        my $coderef = $class->can($sub) or next;

        # Record the frame where the first new instance is seen.
        if ( not defined $currently_visible or $currently_visible != $coderef ) {
          unshift @{ $seen_subs->{$sub} }, $class;    # note: we're working bottom-up
          $currently_visible = $coderef;
          next;
        }
      }
    }
  }

  my $class_data = {};

  # Group "seen subs" into class oriented structures,
  # and classify them.
  for my $sub ( keys %{$seen_subs} ) {
    my @classes = @{ $seen_subs->{$sub} };

    for my $isa ( @{ $seen_subs->{$sub} } ) {

      # mark all subs both shadowing and shadowed until proven otherwise
      $class_data->{$isa}->{$sub} = { shadowed => 1, shadowing => 1 };
    }

    # mark top-most sub unshadowed
    $class_data->{ $classes[0] }->{$sub}->{shadowed} = 0;

    # mark bottom-most sub unshadowing
    $class_data->{ $classes[-1] }->{$sub}->{shadowing} = 0;

  }

  # Order class structures by MRO order
  my (@mro_order) = map { { class => $_, subs => $class_data->{$_} || {} } } @isa;

  if ( 1 > @mro_order or ( 1 >= @mro_order and 1 > keys %{ $mro_order[0]->{subs} } ) ) {

    # Huh, No inheritance, and no subs. K.
    my $module_path = $class;
    $module_path =~ s{ (::|') }{/}sgx;

    # TODO: Maybe don't make this fatal and return data context to user instead?
    # Undecided, and will have to come after more complex concerns.
    # - kentnl, Apr 2016
    if ( not $INC{ $module_path . '.pm' } ) {
      croak "No module called $class successfully loaded" . _E5;
    }
  }
  return \@mro_order;
}

1;

__END__