Merge 7405ed0 into 4b32b3c

kentnl · Jun 26, 2016 · e0c8746 · e0c8746
2 parents 4b32b3c + 7405ed0
commit e0c8746
Show file tree

Hide file tree

Showing 27 changed files with 1,318 additions and 87 deletions.
diff --git a/Changes b/Changes
@@ -1,6 +1,31 @@
 Release history for Devel-Isa-Explainer
 
 {{$NEXT}}
+ - UNIVERSAL now automatically shown in inheritance. ( Closes #11 )
+ - discovering subs using "can" now removed, as "can" was prematurely exposing subs in crossed inheritances, which
+   leads to over-zealous de-duplication, and additional appearances of shadowing where no actual shadowing was
+   happening. ( #10 )
+ - blessed coderefs no longer misunderstood.
+ - deduplicating subs now entirely removed, subs that are actually there in the package must always be displayed as
+   they are either injected by roles or importing, and can actually end up calling themselves under inheritance. ( This
+   however is highly prone to explosions because MRO core sucks ) ( Related to #10 )
+ - isa-splain now supports --help and --version ( Closes #9 )
+
+ [Dependencies::Stats]
+ - Dependencies changed since 0.002001, see misc/*.deps* for details
+ - runtime: +2 -1
+ - test: +1
+
+ [Documentation]
+ - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to
+   work.
+
+ [Internals]
+ - Highligher functions now receive all sub metadata directly as a hash, instead of being called with a list of binary
+   flags.
+ - Parents of classes now recorded in internal data structures, but not yet exposed.
+ - MRO type of classes now recorded in internal data structures.
+ - XSUB, Constant and stub-subs marked in internal data structures.
 
 0.002001 2016-05-19T14:07:12Z c167598
  [Documentation]

diff --git a/Makefile.PL b/Makefile.PL
@@ -20,11 +20,12 @@ my %WriteMakefileArgs = (
   "MIN_PERL_VERSION" => "5.006",
   "NAME" => "Devel::Isa::Explainer",
   "PREREQ_PM" => {
+    "B" => 0,
     "Carp" => 0,
     "Exporter" => 0,
     "MRO::Compat" => 0,
     "Module::Load" => 0,
-    "Package::Stash" => 0,
+    "Scalar::Util" => 0,
     "Term::ANSIColor" => "3.00",
     "constant" => "1.03",
     "namespace::clean" => 0,
@@ -35,25 +36,28 @@ my %WriteMakefileArgs = (
     "ExtUtils::MakeMaker" => 0,
     "File::Spec" => 0,
     "Test::Builder" => 0,
+    "Test::Differences" => 0,
     "Test::More" => "0.89"
   },
-  "VERSION" => "0.002002",
+  "VERSION" => "0.002900",
   "test" => {
-    "TESTS" => "t/*.t t/00-compile/*.t t/cli/*.t t/internals/*.t"
+    "TESTS" => "t/*.t t/00-compile/*.t t/cli/*.t t/internals/*.t t/internals/mro/*.t"
   }
 );
 
 
 my %FallbackPrereqs = (
+  "B" => 0,
   "Carp" => 0,
   "Exporter" => 0,
   "ExtUtils::MakeMaker" => 0,
   "File::Spec" => 0,
   "MRO::Compat" => 0,
   "Module::Load" => 0,
-  "Package::Stash" => 0,
+  "Scalar::Util" => 0,
   "Term::ANSIColor" => "3.00",
   "Test::Builder" => 0,
+  "Test::Differences" => 0,
   "Test::More" => "0.89",
   "constant" => "1.03",
   "namespace::clean" => 0,

diff --git a/README.mkdn b/README.mkdn
@@ -4,7 +4,7 @@ Devel::Isa::Explainer - Pretty Print Hierarchies of Subs in Packages
 
 # VERSION
 
-version 0.002002
+version 0.002900
 
 # SYNOPSIS
 

diff --git a/bin/isa-splain b/bin/isa-splain
@@ -10,12 +10,40 @@ our $VERSION = '0.002002';
 
 # AUTHORITY
 
+# PODNAME: isa-splain
+
 # ABSTRACT: Visualize Module Hierarchies on the command line
 
 use App::Isa::Splain;
 
 App::Isa::Splain->new_from_ARGV->run;
 
-=head1 DESCRIPTION
+=for stopwords isa splain Preload
+
+=head1 USAGE
+
+  isa-splain [OPTS] Module::Name::To::Inspect
+
+=head1 OPTIONS
+
+=head2 -MC<Module::Name>
+
+Preload C<Module::Name> instead of C<Module::Name::To::Inspect>
+
+This is useful in cases where loading C<Module::Name::To::Inspect> directly
+is either impossible ( due to not existing as a .pm file ), or problematic ( due to
+some load time complication )
+
+=head1 EXAMPLES
+
+  isa-splain -MB B::CV
+
+This shows the graph of C<B::CV> after loading C<B.pm>
+
+  isa-splain -Moose Class::MOP::Class
+
+This shows the graph of C<Class::MOP::Class> after loading C<oose.pm>
+
+=head1 SEE ALSO
 
-See L<< C<App::Isa::Splain> |App::Isa::Splain >> For details.
+L<App::Isa::Splain>, L<Devel::Isa::Explainer>
diff --git a/lib/App/Isa/Splain.pm b/lib/App/Isa/Splain.pm
@@ -61,9 +61,18 @@ sub new_from_ARGV {
       push @load_modules, $1;
       next;
     }
-    croak 'Unexpected argument ' . $argument . _E3;
+    ## no critic (RequireCheckedSyscalls)
+    if( '--help' eq $argument) {
+      print _help();
+      exit;
+    }
+    if( '--version' eq $argument ) {
+      print _version();
+      exit;
+    }
+    croak 'Unexpected argument ' . $argument . _E3 . qq[\nSee $0 --help for more information];
   }
-  defined $module or croak 'Expected a module name, got none' . _E1;
+  defined $module or croak 'Expected a module name, got none' . _E1 . qq[\nSee $0 --help for more information];
   return $_[0]->new( module => $module, load_modules => [ @load_modules ? @load_modules : $module ] );
 }
 
@@ -86,6 +95,27 @@ sub run {
   return 0;
 }
 
+sub _help {
+  return <<"EOF";
+Usage: $0 [OPTIONS] MODNAME
+Load and inspect MODNAME's ISA Inheritance.
+
+OPTIONS:
+  -MLoad::Module    - Load "Load::Module" instead of MODNAME ( May be
+                      specified multiple times )
+
+  --help            - Show this help and exit
+  --version         - Show version and exit
+EOF
+}
+
+sub _version {
+  my $pkg = __PACKAGE__;
+  return <<"EOF";
+$0 ($pkg) $VERSION
+EOF
+}
+
 1;
 
 =head1 SYNOPSIS

diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm
@@ -4,22 +4,26 @@ use warnings;
 
 package Devel::Isa::Explainer;
 
-our $VERSION = '0.002002';
+our $VERSION = '0.002900';
 
 # ABSTRACT: Pretty Print Hierarchies of Subs in Packages
 
 # AUTHORITY
 
 use Exporter ();
 use Term::ANSIColor 3.00 ('colored');    # bright_
-use Carp           ('croak');
-use Package::Stash ();
-use MRO::Compat    ();
+use Carp        ('croak');
+use MRO::Compat ();
+use B           ('svref_2object');
+use Devel::Isa::Explainer::_MRO qw( get_linear_class_shadows get_parents );
+
 
 # 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 constant _HAS_CONST => B::CV->can('CONST');
+
 use namespace::clean;
 
 BEGIN { *import = \&Exporter::import }    ## no critic (ProhibitCallsToUnexportedSubs)
@@ -78,21 +82,21 @@ sub _hl_TYPE_UTIL {
 }
 
 sub _hl_suffix {
-  return colored( $_[0], $SHADOW_SUFFIX )   if $_[2];
-  return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1];
+  return colored( $_[0], $SHADOW_SUFFIX )   if $_[1]->{shadowing};
+  return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1]->{shadowed};
   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] );
+  return ( $_[1]->{shadowed} ? colored( \@SHADOWED_PUBLIC, $_[0] ) : colored( \@PUBLIC, $_[0] ) )
+    . _hl_suffix( \@SHADOWED_PUBLIC, $_[1] );
 }
 
 sub _hl_PRIVATE {
-  return ( $_[1] ? colored( \@SHADOWED_PRIVATE, $_[0] ) : colored( \@PRIVATE, $_[0] ) )
-    . _hl_suffix( \@SHADOWED_PRIVATE, $_[1], $_[2] );
+  return ( $_[1]->{shadowed} ? colored( \@SHADOWED_PRIVATE, $_[0] ) : colored( \@PRIVATE, $_[0] ) )
+    . _hl_suffix( \@SHADOWED_PRIVATE, $_[1] );
 }
 
 sub _pp_sub {
@@ -106,13 +110,15 @@ sub _pp_key {
   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, 'Public Sub shadowing another: ' . _hl_PUBLIC( 'shadowing_example', { shadowing => 1 } );
+    push @tokens, 'Public Sub shadowed by higher scope: ' . _hl_PUBLIC( 'shadowed_example', { shadowed => 1 } );
+    push @tokens, 'Public Sub shadowing another and shadowed itself: '
+      . _hl_PUBLIC( 'shadowed_shadowing_example', { shadowing => 1, shadowed => 1 } );
+
+    push @tokens, 'Private/Boring Sub shadowing another: ' . _hl_PRIVATE( 'shadowing_example', { shadowing => 1 } );
+    push @tokens, 'Private/Boring Sub shadowed by higher scope: ' . _hl_PRIVATE( 'shadowed_example', { shadowed => 1 } );
+    push @tokens, 'Private/Boring Sub another and shadowed itself: '
+      . _hl_PRIVATE( 'shadowing_shadowed_example', { shadowed => 1, shadowing => 1 } );
   }
   push @tokens, 'No Subs: ()';
   return sprintf "Key:\n$INDENT%s\n\n", join qq[\n$INDENT], @tokens;
@@ -189,7 +195,7 @@ sub _pp_subs {
 
     # Suck up trailing ,
     $cluster_out =~ s/,[ ]\n\z/\n/sx;
-    $cluster_out =~ s{(\w+)}{ _pp_sub($1, $subs{$1}->{shadowed}, $subs{$1}->{shadowing} ) }gsex;
+    $cluster_out =~ s{(\w+)}{ _pp_sub($1, $subs{$1} ) }gsex;
     push @out_clusters, $cluster_out;
   }
   return join qq[\n], @out_clusters;
@@ -215,60 +221,41 @@ sub _pp_class {
 }
 
 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) = @_;
 
-  my $class_data = {};
+  my (@mro_order) = @{ get_linear_class_shadows($class) };
 
-  # Group "seen subs" into class oriented structures,
-  # and classify them.
-  for my $sub ( keys %{$seen_subs} ) {
-    my @classes = @{ $seen_subs->{$sub} };
+  my $found_interesting = 0;
+  for my $isa_entry (@mro_order) {
 
-    for my $isa ( @{ $seen_subs->{$sub} } ) {
-
-      # mark all subs both shadowing and shadowed until proven otherwise
-      $class_data->{$isa}->{$sub} = { shadowed => 1, shadowing => 1 };
+    # Universal will always be present, but parents/children
+    # of UNIVERSAL are "interesting"
+    next if 'UNIVERSAL' eq $isa_entry->{class};
+    next unless keys %{ $isa_entry->{subs} };
+    $found_interesting++;
+    last;
+  }
+  for my $isa_entry (@mro_order) {
+    $isa_entry->{parents} = get_parents( $isa_entry->{class} );
+    ## no critic (Subroutines::ProhibitCallsToUnexportedSubs)
+    $isa_entry->{mro} = mro::get_mro( $isa_entry->{class} );
+    for my $sub ( keys %{ $isa_entry->{subs} } ) {
+      my $sub_data = $isa_entry->{subs}->{$sub};
+      @{$sub_data}{ 'xsub', 'constant', 'stub' } = ( 0, 0, 0 );
+      my $ref = delete $sub_data->{ref};
+      my $cv  = svref_2object($ref);
+      if ( _HAS_CONST ? $cv->CONST : ref $cv->XSUBANY ) {
+        $sub_data->{constant} = 1;
+      }
+      elsif ( $cv->XSUB ) {
+        $sub_data->{xsub} = 1;
+      }
+      elsif ( not defined &{$ref} ) {
+        $sub_data->{stub} = 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} } ) ) {
+  if ( not $found_interesting ) {
 
     # Huh, No inheritance, and no subs. K.
     my $module_path = $class;