SubstituteAndReturn: chained and contextual

This add support for chained substitutions of the form ... =~ s///r =~ s///r =~ s///r as well as substitutions that are contextually performed on the `$_` variable (i.e., they do not have a binding operator `=~`). Fixes <shadow-dot-cat#7>.
zmughal · Apr 5, 2022 · 8148cbc · 8148cbc
1 parent e4bae73
commit 8148cbc
Show file tree

Hide file tree

Showing 2 changed files with 131 additions and 17 deletions.
diff --git a/lib/Babble/Plugin/SubstituteAndReturn.pm b/lib/Babble/Plugin/SubstituteAndReturn.pm
@@ -2,25 +2,122 @@ package Babble::Plugin::SubstituteAndReturn;
 
 use Moo;
 
+my $FLAGS_RE = qr/([msixpodualgcern]*+)$/;
+
+sub _transform_binary {
+  my ($self, $top) = @_;
+  my $replaced;
+  do {
+    $replaced = 0;
+    $top->each_match_within(BinaryExpression => [
+       [ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ],
+       '(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))',
+       [ 'right' => '(?>(?&PerlSubstitution))' ],
+    ] => sub {
+      my ($m) = @_;
+      my ($left, $right);
+      eval {
+        ($left, $right) = $m->subtexts(qw(left right));
+        1
+      } or return;
+      my ($flags) = $right =~ $FLAGS_RE;
+      return unless (my $newflags = $flags) =~ s/r//g;
+
+      # find chained substitutions
+      #   ... =~ s///r =~ s///r =~ s///r
+      my $top_text = $top->text;
+      pos( $top_text ) = $m->start + length $m->text;
+      my $chained_subs_length = 0;
+      my @chained_subs;
+      while( $top_text =~ /
+        \G
+          (
+            (?>(?&PerlOWS)) =~ (?>(?&PerlOWS))
+            ( (?>(?&PerlSubstitution)) )
+          )
+          @{[ $m->grammar_regexp ]}
+        /xg ) {
+        $chained_subs_length += length $1;
+        push @chained_subs, $2;
+      }
+      for my $subst_c (@chained_subs) {
+        my ($f_c) = $subst_c =~ $FLAGS_RE;
+        die "Chained substitution must use the /r modifier"
+          unless (my $nf_c = $f_c) =~ s/r//g;
+        $subst_c =~ s/\Q${f_c}\E$/${nf_c}/;
+      }
+
+      $right =~ s/\Q${flags}\E$/${newflags}/;
+      $left =~ s/\s+$//;
+      my $genlex = '$'.$m->gensym;
+
+      if( @chained_subs ) {
+        my $chained_for = 'for ('.$genlex.') { '
+          . join("; ", @chained_subs)
+          . ' }';
+        $top->replace_substring(
+          $m->start,
+          length($m->text) + $chained_subs_length,
+          '(map { (my '.$genlex.' = $_) =~ '.$right.'; '.$chained_for.' '.$genlex.' }'
+          .' '.$left.')[0]'
+        );
+      } else {
+        $m->replace_text(
+          '(map { (my '.$genlex.' = $_) =~ '.$right.'; '.$genlex.' }'
+          .' '.$left.')[0]'
+        );
+      }
+
+      $replaced++;
+    });
+  } while( $replaced );
+}
+
+sub _transform_contextualise {
+  my ($self, $top) = @_;
+
+  my $contextual_subst = 0;
+  do {
+    my %subst_pos;
+    # Look for substitution without binding operator:
+    # First look for an expression that begins with Substitution.
+    $top->each_match_within(Expression => [
+      [ subst => '(?> (?&PerlSubstitution) )' ],
+    ] => sub {
+      my ($m) = @_;
+      my ($subst) = @{$m->submatches}{qw(subst)};
+      my ($flags) = $subst->text =~ /([msixpodualgcern]*+)$/;
+      return unless (my $newflags = $flags) =~ s/r//g;
+      $subst_pos{$m->start} = 1;
+    });
+    # Then remove Substitution within a BinaryExpression
+    $top->each_match_within(BinaryExpression => [
+       [ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ],
+       '(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))',
+       [ 'right' => '(?>(?&PerlSubstitution))' ],
+    ] => sub {
+      my ($m) = @_;
+      delete $subst_pos{ $m->start + $m->submatches->{right}->start };
+    });
+
+    # Insert context variable and binding operator
+    my @subst_pos = sort keys %subst_pos;
+    $contextual_subst = @subst_pos;
+    my $diff = 0;
+    my $replace = '$_ =~ ';
+    while( my $pos = shift @subst_pos ) {
+      $top->replace_substring($pos + $diff, 0, $replace);
+      $diff += length $replace;
+    }
+  } while( $contextual_subst);
+}
+
 sub transform_to_plain {
   my ($self, $top) = @_;
-  $top->each_match_within(BinaryExpression => [
-     [ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ],
-     '(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))',
-     [ 'right' => '(?>(?&PerlSubstitution))' ],
-  ] => sub {
-    my ($m) = @_;
-    my ($left, $right) = $m->subtexts(qw(left right));
-    my ($flags) = $right =~ /([msixpodualgcern]*+)$/;
-    return unless (my $newflags = $flags) =~ s/r//g;
-    $right =~ s/\Q${flags}\E$/${newflags}/;
-    $left =~ s/\s+$//;
-    my $genlex = '$'.$m->gensym;
-    $m->replace_text(
-      '(map { (my '.$genlex.' = $_) =~ '.$right.'; '.$genlex.' }'
-      .' '.$left.')[0]'
-    );
-  });
+
+  $self->_transform_contextualise($top);
+
+  $self->_transform_binary($top);
 }
 
 1;
diff --git a/t/plugin-substituteandreturn.t b/t/plugin-substituteandreturn.t
@@ -8,6 +8,23 @@ my $sr = Babble::Plugin::SubstituteAndReturn->new;
 my @cand = (
   [ 'my $foo = $bar =~ s/baz/quux/r;',
     'my $foo = (map { (my $__B_001 = $_) =~ s/baz/quux/; $__B_001 } $bar)[0];', ],
+  [ '$foo =~ s/foo/bar/gr =~ s/(bar)+/baz/gr',
+    '(map { (my $__B_001 = $_) =~ s/foo/bar/g; for ($__B_001) { s/(bar)+/baz/g } $__B_001 } $foo)[0]', ],
+  [ 'map { s/foo/bar/gr =~ s/(bar)+/baz/gr =~ s/xyzzy/ijk/gr } @list',
+    'map { (map { (my $__B_001 = $_) =~ s/foo/bar/g; for ($__B_001) { s/(bar)+/baz/g; s/xyzzy/ijk/g } $__B_001 } $_)[0] } @list', ],
+  [ 'my @new = map { s|foo|bar|gr } @old',
+    'my @new = map { (map { (my $__B_001 = $_) =~ s|foo|bar|g; $__B_001 } $_)[0] } @old', ],
+  [ 'while(<>) { print( s/aa/1/gr =~ s/bb/2/gr =~ s/cc/3/gr ); }',
+    'while(<>) { print( (map { (my $__B_001 = $_) =~ s/aa/1/g; for ($__B_001) { s/bb/2/g; s/cc/3/g } $__B_001 } $_)[0] ); }', ],
+  [ 'while(<>) {
+       print( s/aa/1/gr =~ s/bb/2/gr =~ s/cc/3/gr );
+       print( s/dd/4/gr =~ s/ee/5/gr =~ s/ff/6/gr );
+     }',
+    'while(<>) {
+       print( (map { (my $__B_001 = $_) =~ s/aa/1/g; for ($__B_001) { s/bb/2/g; s/cc/3/g } $__B_001 } $_)[0] );
+       print( (map { (my $__B_002 = $_) =~ s/dd/4/g; for ($__B_002) { s/ee/5/g; s/ff/6/g } $__B_002 } $_)[0] );
+     }',
+    ],
 );
 
 foreach my $cand (@cand) {