handle nested subs

uperl · Dec 27, 2024 · be74c65 · be74c65
1 parent 0557542
commit be74c65
Show file tree

Hide file tree

Showing 3 changed files with 43 additions and 4 deletions.
diff --git a/Changes b/Changes
@@ -1,10 +1,11 @@
 Revision history for {{$dist->name}}
 
 {{$NEXT}}
+  - (ProhibitSignaturesAndAtUnderscore) Do not detect @_ inside nested sub (gh#10, gh#11)
 
 0.08      2024-12-27 09:48:41 -0700
   - Documentation fixes and improvements.
-  - More accurately detect signatures for Policy Plicease::ProhibitSignaturesAndAtUnderscore (MITHALDU++, gh#9)
+  - (ProhibitSignaturesAndAtUnderscore) More accurately detect signatures (MITHALDU++, gh#9)
 
 0.07      2024-05-29 20:01:09 -0600
   - (ProhibitUnicodeDigitInRegexp) Treat digit character class /[:digit:]/

diff --git a/lib/Perl/Critic/Policy/Plicease/ProhibitSignaturesAndAtUnderscore.pm b/lib/Perl/Critic/Policy/Plicease/ProhibitSignaturesAndAtUnderscore.pm
@@ -86,9 +86,8 @@ sub violates {
     foreach my $sub (@$subs) {
       next unless( $PPI::Document::VERSION > 1.279 ?
         @{$sub->find('PPI::Structure::Signature')} : defined $sub->prototype );
-      my $symbols = $sub->find('PPI::Token::Symbol') || [];
-      foreach my $symbol (@$symbols) {
-        next unless $symbol->symbol eq '@_';
+
+      foreach my $symbol ( _recurse($sub->schildren) ) {
         push @violations, $self->violation(DESC, EXPL, $symbol);
       }
     }
@@ -97,4 +96,23 @@ sub violates {
   return @violations;
 }
 
+# since PPI doesn't detect anonymous subroutines...
+# look to ignore a PPI::Token::Word with `sub` followed by sibling PPI::Structure::Block
+
+sub _recurse {
+  my @ret;
+  my(@children) = @_;
+  for my $i (0..$#children) {
+    next if $children[$i]->isa('PPI::Statement::Sub');
+    next if $i >= 1 && $children[$i]->isa('PPI::Structure::Block') && $children[$i-1]->isa('PPI::Token::Word') && $children[$i-1]->literal eq 'sub';
+
+    if($children[$i]->isa('PPI::Token::Symbol') && $children[$i]->symbol eq '@_') {
+      push @ret, $children[$i];
+    } elsif($children[$i]->can('schildren')) {
+      push @ret, _recurse($children[$i]->schildren);
+    }
+  }
+  return @ret;
+}
+
 1;
diff --git a/t/Plicease/ProhibitSignaturesAndAtUnderscore.run b/t/Plicease/ProhibitSignaturesAndAtUnderscore.run
@@ -25,3 +25,23 @@ sub foo ($a) {
 sub foo ($$) {
   my @x = @_;
 }
+
+## name code ref inside sub with sig
+## failures 0
+## cut
+
+use experimental qw( signatures );
+
+sub foo ($a) {
+    return sub { return @_ }
+}
+
+## name code ref inside sub with sig
+## failures 0
+## cut
+
+use experimental qw( signatures );
+
+sub foo ($a) {
+    sub bar { return @_ }
+}