Merge 766c5e0 into 4b32b3c

Changes

@@ -1,6 +1,9 @@
 Release history for Devel-Isa-Explainer
 
 {{$NEXT}}
+ [Dependencies::Stats]
+ - Dependencies changed since 0.002001, see misc/*.deps* for details
+ - runtime: +2
 
 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,
@@ -45,13 +47,15 @@ my %WriteMakefileArgs = (
 
 
 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",

lib/Devel/Isa/Explainer.pm

@@ -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;
@@ -254,7 +288,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

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
+ [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
+ [Added / runtime requires]
+ - B
+ - Scalar::Util
 
 0.002001 2016-05-19T14:07:12Z
 

perlcritic.rc

@@ -369,7 +369,7 @@ base_max = 130
 
 [ValuesAndExpressions::ProhibitBarewordDoubleColon]
 
-[ValuesAndExpressions::ProhibitCommaSeparatedStatements]
+[-ValuesAndExpressions::ProhibitCommaSeparatedStatements]
 
 [ValuesAndExpressions::ProhibitComplexVersion]
 

t/02-shadowing.t

@@ -68,17 +68,17 @@ is( scalar keys %{ $mro->[2]->{subs} }, 3, "base class has 3 subs" );
 
 is_deeply(
   $mro->[0]->{subs}->{three_layer_shadow},
-  { shadowing => 1, shadowed => 0 },
+  { shadowing => 1, shadowed => 0, xsub => 0, constant => 0 },
   "three layer shadow top layer shadowing but not shadowed"
 );
 is_deeply(
   $mro->[1]->{subs}->{three_layer_shadow},
-  { shadowing => 1, shadowed => 1 },
+  { shadowing => 1, shadowed => 1, xsub => 0, constant => 0 },
   "three layer shadow middle layer shadowing and shadowed"
 );
 is_deeply(
   $mro->[2]->{subs}->{three_layer_shadow},
-  { shadowing => 0, shadowed => 1 },
+  { shadowing => 0, shadowed => 1, xsub => 0, constant => 0 },
   "three layer shadow bottom layer shadowed but not shadowing"
 );
 

t/internals/01-discover_xsub.t

@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+
+use Test::More;
+use B ();
+
+use Devel::Isa::Explainer ();
+
+*extract_mro = \&Devel::Isa::Explainer::_extract_mro;
+{
+  my $mro  = extract_mro("B");
+  my $fail = 0;
+  for my $class ( @{$mro} ) {
+    next unless $class->{class} eq 'B';
+    $fail = 1 unless ok( exists $class->{subs}->{'svref_2object'},  "svref_2object discovered in class" );
+    $fail = 1 unless ok( $class->{subs}->{'svref_2object'}->{xsub}, "svref_2object is an XSUB" );
+  }
+  diag explain $mro if $fail;
+
+}
+{
+  my $mro  = extract_mro("Devel::Isa::Explainer");
+  my $fail = 0;
+  for my $class ( @{$mro} ) {
+    next unless $class->{class} eq 'Devel::Isa::Explainer';
+    $fail = 1 unless ok( exists $class->{subs}->{'explain_isa'},   "explain_isa discovered in class" );
+    $fail = 1 unless ok( !$class->{subs}->{'explain_isa'}->{xsub}, "explain_isa is NOT an XSUB" );
+  }
+  diag explain $mro if $fail;
+}
+
+done_testing;

t/internals/03-discover-constant.t

@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+use Test::More;
+{
+  package My::Test;
+  sub constant_sub() { 'Hello' }
+}
+use Devel::Isa::Explainer ();
+
+*extract_mro = \&Devel::Isa::Explainer::_extract_mro;
+{
+  my $mro  = extract_mro("My::Test");
+  my $fail = 0;
+  for my $class ( @{$mro} ) {
+    next unless $class->{class} eq 'My::Test';
+    $fail = 1 unless ok( exists $class->{subs}->{'constant_sub'},  "constant_sub discovered in class" );
+    $fail = 1 unless ok( $class->{subs}->{'constant_sub'}->{constant}, "constant_sub is a constant sub" );
+  }
+  diag explain $mro if $fail;
+
+}
+{
+  my $mro  = extract_mro("Devel::Isa::Explainer");
+  my $fail = 0;
+  for my $class ( @{$mro} ) {
+    next unless $class->{class} eq 'Devel::Isa::Explainer';
+    $fail = 1 unless ok( exists $class->{subs}->{'explain_isa'},   "explain_isa discovered in class" );
+    $fail = 1 unless ok( !$class->{subs}->{'explain_isa'}->{constant}, "explain_isa is NOT a constant sub" );
+  }
+  diag explain $mro if $fail;
+}
+
+done_testing;

t/internals/04-blessed_subs.t

@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+
+use Test::More;
+use B qw();
+{
+  package My::Test;
+  sub constant_sub() { 'Hello' }
+  BEGIN {
+    bless \&My::Test::constant_sub, 'My::Test';
+    *My::Test::xsub = \&B::svref_2object;
+    bless \&My::Test::xsub, 'B';
+  };
+}
+
+use Devel::Isa::Explainer ();
+
+*extract_mro = \&Devel::Isa::Explainer::_extract_mro;
+{
+  my $mro  = extract_mro("My::Test");
+  my $fail = 0;
+  for my $class ( @{$mro} ) {
+    next unless $class->{class} eq 'My::Test';
+    $fail = 1 unless ok( exists $class->{subs}->{'constant_sub'},  "constant_sub discovered in class" );
+    $fail = 1 unless ok( $class->{subs}->{'constant_sub'}->{constant}, "constant_sub is a constant sub" );
+    $fail = 1 unless ok( exists $class->{subs}->{'xsub'},  "xsub discovered in class" );
+    $fail = 1 unless ok( $class->{subs}->{'xsub'}->{xsub}, "xsub is an XSUB" );
+  }
+  diag explain $mro if $fail;
+
+}
+done_testing;