Xsub detection

Changes

@@ -1,6 +1,7 @@
 Release history for Devel-Isa-Explainer
 
 {{$NEXT}}
+ - CLONE/CLONE_SKIP now exempt from shadowing logic. ( Closes #5 )
 
 0.002900 2016-06-26T19:35:43Z 7405ed0
  - UNIVERSAL now automatically shown in inheritance. ( Closes #11 )

lib/Devel/Isa/Explainer.pm

@@ -40,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>
 
@@ -82,8 +87,21 @@ sub _hl_TYPE_UTIL {
 }
 
 sub _hl_suffix {
-  return colored( $_[0], $SHADOW_SUFFIX )   if $_[1]->{shadowing};
-  return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1]->{shadowed};
+  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[];
 }
 
@@ -120,6 +138,16 @@ sub _pp_key {
     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;
 }

lib/Devel/Isa/Explainer/_MRO.pm

@@ -21,8 +21,6 @@ BEGIN {
   *_mro_is_universal   = \&mro::is_universal;
 }
 
-# yes, this is evil
-
 our @EXPORT_OK = qw(
   is_mro_proxy
   get_linear_isa
@@ -35,6 +33,18 @@ our @EXPORT_OK = qw(
   get_flattened_class
 );
 
+our %SHADOW_EXEMPT = (
+  map { $_ => 1 } (
+
+    # http://perldoc.perl.org/perlmod.html#Making-your-module-threadsafe
+    # CLONE is called at all levels, shadowed or not
+    'CLONE',
+
+    # CLONE_SKIP is also called on all levels, shadowed or not.
+    ( $] >= 5.008007 ? 'CLONE_SKIP' : () ),
+  )
+);
+
 BEGIN {
   # MRO Proxies removed since 5.009_005
   *MRO_PROXIES = ( $] <= 5.009005 ) ? sub() { 1 } : sub() { 0 };
@@ -219,8 +229,13 @@ sub get_linear_class_shadows {
         $methods->{$subname} = $node->{$subname};
         next;
       }
-      $node->{$subname} = { shadowing => 1, shadowed => 0, ref => $subs->{$subname} };
-      $methods->{$subname}->{shadowed} = 1;        # mark previous version shadowed
+      if ( exists $SHADOW_EXEMPT{$subname} ) {
+        $node->{$subname} = { shadowing => 0, shadowed => 0, ref => $subs->{$subname} };
+      }
+      else {
+        $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 };