From d4a05a12c0322b45387e6d7ccf5c1990da77662a Mon Sep 17 00:00:00 2001 From: Zakariyya Mughal Date: Fri, 1 Apr 2022 22:16:45 -0400 Subject: [PATCH 1/2] 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..8c01b5f 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 =~ $FLAGS_RE; + return unless $flags =~ /r/; + $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) { From 2b634d7a5923d72af0fbe83008d0a268bf1e7fe6 Mon Sep 17 00:00:00 2001 From: Zakariyya Mughal Date: Tue, 16 Aug 2022 15:55:01 -0400 Subject: [PATCH 2/2] SubstituteAndReturn: Add support for y///r Connects with . --- lib/Babble/Plugin/SubstituteAndReturn.pm | 34 ++++++++++++++++++------ t/plugin-substituteandreturn.t | 14 ++++++++++ 2 files changed, 40 insertions(+), 8 deletions(-) diff --git a/lib/Babble/Plugin/SubstituteAndReturn.pm b/lib/Babble/Plugin/SubstituteAndReturn.pm index 8c01b5f..af637f8 100644 --- a/lib/Babble/Plugin/SubstituteAndReturn.pm +++ b/lib/Babble/Plugin/SubstituteAndReturn.pm @@ -2,7 +2,13 @@ package Babble::Plugin::SubstituteAndReturn; use Moo; -my $FLAGS_RE = qr/([msixpodualgcern]*+)$/; +my $s_FLAGS_RE = qr/([msixpodualgcern]*+)$/; +my $y_FLAGS_RE = qr/([cdsr]*+)$/; + +sub _get_flags { + my ($text) = @_; + $text =~ /^s/ ? $s_FLAGS_RE : $y_FLAGS_RE; +} sub _transform_binary { my ($self, $top) = @_; @@ -12,7 +18,10 @@ sub _transform_binary { $top->each_match_within(BinaryExpression => [ [ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ], '(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))', - [ 'right' => '(?>(?&PerlSubstitution))' ], + [ 'right' => '(?> + (?&PerlSubstitution) + | (?&PerlTransliteration) + )' ], ] => sub { my ($m) = @_; my ($left, $right); @@ -20,7 +29,7 @@ sub _transform_binary { ($left, $right) = $m->subtexts(qw(left right)); 1 } or return; - my ($flags) = $right =~ $FLAGS_RE; + my ($flags) = $right =~ _get_flags($right); return unless (my $newflags = $flags) =~ s/r//g; # find chained substitutions @@ -33,7 +42,10 @@ sub _transform_binary { \G ( (?>(?&PerlOWS)) =~ (?>(?&PerlOWS)) - ( (?>(?&PerlSubstitution)) ) + ((?> + (?&PerlSubstitution) + | (?&PerlTransliteration) + )) ) @{[ $m->grammar_regexp ]} /xg ) { @@ -41,7 +53,7 @@ sub _transform_binary { push @chained_subs, $2; } for my $subst_c (@chained_subs) { - my ($f_c) = $subst_c =~ $FLAGS_RE; + my ($f_c) = $subst_c =~ _get_flags($subst_c); 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}/; @@ -82,11 +94,14 @@ sub _transform_contextualise { # Look for substitution without binding operator: # First look for an expression that begins with Substitution. $top->each_match_within(Expression => [ - [ subst => '(?> (?&PerlSubstitution) )' ], + [ subst => '(?> + (?&PerlSubstitution) + | (?&PerlTransliteration) + )' ], ] => sub { my ($m) = @_; my ($subst) = @{$m->submatches}{qw(subst)}; - my ($flags) = $subst->text =~ $FLAGS_RE; + my ($flags) = $subst->text =~ _get_flags($subst->text); return unless $flags =~ /r/; $subst_pos{$m->start} = 1; }); @@ -94,7 +109,10 @@ sub _transform_contextualise { $top->each_match_within(BinaryExpression => [ [ 'left' => '(?>(?&PerlPrefixPostfixTerm))' ], '(?>(?&PerlOWS)) =~ (?>(?&PerlOWS))', - [ 'right' => '(?>(?&PerlSubstitution))' ], + [ 'right' => '(?> + (?&PerlSubstitution) + | (?&PerlTransliteration) + )' ], ] => sub { my ($m) = @_; delete $subst_pos{ $m->start + $m->submatches->{right}->start }; diff --git a/t/plugin-substituteandreturn.t b/t/plugin-substituteandreturn.t index e4195b9..e2d495a 100644 --- a/t/plugin-substituteandreturn.t +++ b/t/plugin-substituteandreturn.t @@ -25,6 +25,20 @@ my @cand = ( print( (map { (my $__B_002 = $_) =~ s/dd/4/g; for ($__B_002) { s/ee/5/g; s/ff/6/g } $__B_002 } $_)[0] ); }', ], + [ 'my $foo = $bar =~ y/a-c/d/r;', + 'my $foo = (map { (my $__B_001 = $_) =~ y/a-c/d/; $__B_001 } $bar)[0];', ], + [ q{ + while(<>) { + print( y/a-c/d/r =~ tr/d/z/cr ); + print( y/a-c/d/r =~ s/d/foo/gr ); + } + }, q{ + while(<>) { + print( (map { (my $__B_001 = $_) =~ y/a-c/d/; for ($__B_001) { tr/d/z/c } $__B_001 } $_)[0] ); + print( (map { (my $__B_002 = $_) =~ y/a-c/d/; for ($__B_002) { s/d/foo/g } $__B_002 } $_)[0] ); + } + } + ], ); foreach my $cand (@cand) {