Merge f9ba3d8 into 4b32b3c

Changes

@@ -1,6 +1,24 @@
 Release history for Devel-Isa-Explainer
 
 {{$NEXT}}
+ - UNIVERSAL now automatically shown in inheritance. ( Closes #11 )
+
+ [Dependencies::Stats]
+ - Dependencies changed since 0.002001, see misc/*.deps* for details
+ - runtime: +2
+
+ [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.
+ - Now detects "XSUB" property of subroutines, but this data is not yet exposed.
+ - Now detects "CONSTANT" property of subroutines, but this data is not yet exposed.
+ - No longer confused by blessed coderefs.
+ - MRO Type of classes now recorded in internal data structures, but not yet exposed.
+ - Parents of classes now recorded in internal data structures, but not yet exposed.
 
 0.002001 2016-05-19T14:07:12Z c167598
  [Documentation]

Makefile.PL

@@ -20,11 +20,13 @@ 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,
@@ -37,21 +39,23 @@ my %WriteMakefileArgs = (
     "Test::Builder" => 0,
     "Test::More" => "0.89"
   },
-  "VERSION" => "0.002002",
+  "VERSION" => "0.003000",
   "test" => {
     "TESTS" => "t/*.t t/00-compile/*.t t/cli/*.t t/internals/*.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::More" => "0.89",

README.mkdn

@@ -4,7 +4,7 @@ Devel::Isa::Explainer - Pretty Print Hierarchies of Subs in Packages
 
 # VERSION
 
-version 0.002002
+version 0.003000
 
 # SYNOPSIS
 

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>

lib/Devel/Isa/Explainer.pm

@@ -4,7 +4,7 @@ use warnings;
 
 package Devel::Isa::Explainer;
 
-our $VERSION = '0.002002';
+our $VERSION = '0.003000';
 
 # ABSTRACT: Pretty Print Hierarchies of Subs in Packages
 
@@ -15,6 +15,10 @@ use Term::ANSIColor 3.00 ('colored');    # bright_
 use Carp           ('croak');
 use Package::Stash ();
 use MRO::Compat    ();
+use B              ('svref_2object');
+use Scalar::Util   ('reftype');
+
+use constant _HAS_CONST => B::CV->can('CONST');
 
 # Perl critic is broken. This is not a void context.
 ## no critic (BuiltinFunctions::ProhibitVoidMap)
@@ -36,12 +40,17 @@ 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';
+our $MAX_WIDTH              = 80;
+our $SHOW_SHADOWED          = 1;
+our $INDENT                 = q[ ] x 4;
+our $SUFFIX_START           = q{(};
+our $SUFFIX_STOP            = q{)};
+our $SHADOWING_SUFFIX       = q{^};
+our $CONSTANT_SUFFIX        = q{};                # TBD
+our $XSUB_SUFFIX            = q{};                # TBD
+our $SHADOWED_SUFFIX        = q{};                # TBD
+our $SHADOWED_BOTTOM_SUFFIX = q{};                # TBD
+our $CLUSTERING             = 'type_clustered';
 
 =func C<explain_isa>
 
@@ -78,21 +87,34 @@ sub _hl_TYPE_UTIL {
 }
 
 sub _hl_suffix {
-  return colored( $_[0], $SHADOW_SUFFIX )   if $_[2];
-  return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1];
+  my ($suffix_flags) = q[];
+  if ( $_[1]->{shadowed} and not $_[1]->{shadowing} ) {
+    $suffix_flags .= $SHADOWED_BOTTOM_SUFFIX;
+  }
+  else {
+    $suffix_flags .= $SHADOWING_SUFFIX if $_[1]->{shadowing};
+    $suffix_flags .= $SHADOWED_SUFFIX  if $_[1]->{shadowed};
+  }
+  $suffix_flags .= $XSUB_SUFFIX     if $_[1]->{xsub};
+  $suffix_flags .= $CONSTANT_SUFFIX if $_[1]->{constant};
+
+  return colored( $_[0], $SUFFIX_START . $suffix_flags . $SUFFIX_STOP )
+    if length $suffix_flags and ( $_[1]->{shadowing} or $_[1]->{shadowed} );
+  return $SUFFIX_START . $suffix_flags . $SUFFIX_STOP if length $suffix_flags;
+
   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,14 +128,26 @@ 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 } );
   }
+  my @suffixes;
+  if ($SHOW_SHADOWED) {
+    push @suffixes, 'shadowing=' . _hl_suffix( ['reset'], { shadowing => 1 } ) if length $SHADOWING_SUFFIX;
+    push @suffixes, 'shadowed=' . _hl_suffix( ['reset'], { shadowing => 1, shadowed => 1 } ) if length $SHADOWED_SUFFIX;
+    push @suffixes, 'last_shadowed=' . _hl_suffix( ['reset'], { shadowed => 1 } ) if length $SHADOWED_BOTTOM_SUFFIX;
+  }
+  push @suffixes, 'xsub=' . _hl_suffix( ['reset'], { xsub => 1 } ) if length $XSUB_SUFFIX;
+  push @suffixes, 'constant=' . _hl_suffix( ['reset'], { constant => 1 } ) if length $CONSTANT_SUFFIX;
+
+  push @tokens, 'Suffixes: ' . join q[, ], @suffixes if @suffixes;
   push @tokens, 'No Subs: ()';
   return sprintf "Key:\n$INDENT%s\n\n", join qq[\n$INDENT], @tokens;
 }
@@ -189,7 +223,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;
@@ -214,12 +248,10 @@ sub _pp_class {
   return $out;
 }
 
-sub _extract_mro {
-  my ($class)     = @_;
-  my ($seen_subs) = {};
-
-  ## no critic (ProhibitCallsToUnexportedSubs)
-  my (@isa) = @{ mro::get_linear_isa($class) };
+sub _extract_subs {
+  my (@isa)             = @_;
+  my $seen_subs         = {};
+  my $found_interesting = 0;
 
   # Discover all subs and compute full MRO every time a new sub-name
   # is found
@@ -228,7 +260,6 @@ sub _extract_mro {
       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 ) {
@@ -237,12 +268,28 @@ sub _extract_mro {
         # 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
+          ## no critic (ProhibitCallsToUnexportedSubs)
+          $found_interesting++ unless mro::is_universal($class);
           $currently_visible = $coderef;
           next;
         }
       }
     }
   }
+  return ( $found_interesting, $seen_subs );
+}
+
+sub _extract_mro {
+  my ($class) = @_;
+
+  ## no critic (ProhibitCallsToUnexportedSubs)
+  my (@isa) = @{ mro::get_linear_isa($class) };
+
+  # UNIVERSAL must be assumed last because mro does not return it
+  #   this also returns any parents UNIVERSAL may have had injected.
+  push @isa, @{ mro::get_linear_isa('UNIVERSAL') };
+
+  my ( $found_interesting, $seen_subs ) = _extract_subs(@isa);
 
   my $class_data = {};
 
@@ -254,7 +301,12 @@ sub _extract_mro {
     for my $isa ( @{ $seen_subs->{$sub} } ) {
 
       # mark all subs both shadowing and shadowed until proven otherwise
-      $class_data->{$isa}->{$sub} = { shadowed => 1, shadowing => 1 };
+      $class_data->{$isa}->{$sub} = { shadowed => 1, shadowing => 1, xsub => 0, constant => 0 };
+      my $coderef = $isa->can($sub);
+      next unless 'CODE' eq reftype $coderef;
+      my $cv = svref_2object($coderef);
+      $class_data->{$isa}->{$sub}->{constant} = 1, next if _HAS_CONST ? $cv->CONST : ref $cv->XSUBANY;
+      $class_data->{$isa}->{$sub}->{xsub} = 1 if $cv->XSUB;
     }
 
     # mark top-most sub unshadowed
@@ -266,9 +318,24 @@ sub _extract_mro {
   }
 
   # Order class structures by MRO order
-  my (@mro_order) = map { { class => $_, subs => $class_data->{$_} || {} } } @isa;
+  my (@mro_order);
+  for my $class (@isa) {
+    my $isa = Package::Stash->new($class)->get_symbol('@ISA');    ## no critic (RequireInterpolationOfMetachars)
+    my $parents = $isa || [];
+    if ( not @{$parents} and not mro::is_universal($class) ) {
+      $parents = ['UNIVERSAL'];
+    }
+    my $class_record = {
+      class   => $class,
+      subs    => {},
+      mro     => mro::get_mro($class),
+      parents => $parents,
+    };
+    $class_record->{subs} = $class_data->{$class} if $class_data->{$class};
+    push @mro_order, $class_record;
+  }
 
-  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;

maint/perlcritic.rc.gen.pl

@@ -30,6 +30,7 @@
 $bundle->remove_policy('TestingAndDebugging::ProhibitNoStrict');
 $bundle->remove_policy('Subroutines::ProhibitCallsToUndeclaredSubs');
 $bundle->remove_policy('Subroutines::RequireArgUnpacking');
+$bundle->remove_policy('ValuesAndExpressions::ProhibitCommaSeparatedStatements');
 #$bundle->remove_policy('CodeLayout::RequireUseUTF8');
 #$bundle->remove_policy('ErrorHandling::RequireCarping');
 $bundle->remove_policy('NamingConventions::Capitalization');

misc/Changes.deps

@@ -1,6 +1,9 @@
 This file contains changes in REQUIRED dependencies for standard CPAN phases (configure/build/runtime/test)
 
-0.002002
+0.003000
+ [Added / runtime requires]
+ - B
+ - Scalar::Util
 
 0.002001 2016-05-19T14:07:12Z
 

misc/Changes.deps.all

@@ -1,6 +1,9 @@
 This file contains ALL changes in dependencies in both REQUIRED / OPTIONAL dependencies for all phases (configure/build/runtime/test/develop)
 
-0.002002
+0.003000
+ [Added / runtime requires]
+ - B
+ - Scalar::Util
 
 0.002001 2016-05-19T14:07:12Z
 

misc/Changes.deps.dev

@@ -1,6 +1,6 @@
 This file contains changes to DEVELOPMENT dependencies only ( both REQUIRED and OPTIONAL )
 
-0.002002
+0.003000
 
 0.002001 2016-05-19T14:07:12Z
 

misc/Changes.deps.opt

@@ -1,6 +1,6 @@
 This file contains changes in OPTIONAL dependencies for standard CPAN phases (configure/build/runtime/test)
 
-0.002002
+0.003000
 
 0.002001 2016-05-19T14:07:12Z