From 8148cbcf618c9eadb39aa4e76ee443bf43a9dc1f Mon Sep 17 00:00:00 2001 From: Zakariyya Mughal Date: Fri, 1 Apr 2022 22:16:45 -0400 Subject: [PATCH] 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 . --- lib/Babble/Plugin/SubstituteAndReturn.pm | 131 ++++++++++++++++++++--- t/plugin-substituteandreturn.t | 17 +++ 2 files changed, 131 insertions(+), 17 deletions(-) diff --git a/lib/Babble/Plugin/SubstituteAndReturn.pm b/lib/Babble/Plugin/SubstituteAndReturn.pm index 7fa9318..f06fcaa 100644 --- 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 index 833470c..e4195b9 100644 --- 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) {