s/\ba/./g was over-optimized

To: Mailing list Perl5 <perl5-porters@perl.org>
Message-ID: <19990207172522.B894@monk.mps.ohio-state.edu>

p4raw-id: //depot/cfgperl@2841

diff --git a/MANIFEST b/MANIFEST
index e215e75..d95ed45 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1190,6 +1190,8 @@ t/op/sprintf.t            See if sprintf works
 t/op/stat.t            See if stat works
 t/op/study.t           See if study works
 t/op/subst.t           See if substitution works
+t/op/subst_amp.t       See if $&-related substitution works
+t/op/subst_wamp.t      See if substitution works with $& present
 t/op/substr.t          See if substr works
 t/op/sysio.t           See if sysread and syswrite work
 t/op/taint.t           See if tainting works

diff --git a/regcomp.c b/regcomp.c
index f78388b..2d5f813 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -1765,6 +1765,7 @@ tryagain:
            break;
        case 'b':
            PL_seen_zerolen++;
+           PL_regseen |= REG_SEEN_LOOKBEHIND;
            ret = reg_node(
                UTF
                    ? (LOC ? BOUNDLUTF8 : BOUNDUTF8)
@@ -1776,6 +1777,7 @@ tryagain:
            break;
        case 'B':
            PL_seen_zerolen++;
+           PL_regseen |= REG_SEEN_LOOKBEHIND;
            ret = reg_node(
                UTF
                    ? (LOC ? NBOUNDLUTF8 : NBOUNDUTF8)

diff --git a/t/op/subst.t b/t/op/subst.t
index 6776a1e..69e474f 100755 (executable)
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -6,7 +6,7 @@ BEGIN {
     require Config; import Config;
 }
 
-print "1..93\n";
+print "1..82\n";
 
 $x = 'foo';
 $_ = "x";
@@ -312,7 +312,7 @@ s{  \d+          \b [,.;]? (?{ 'digits' })
 print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n");
 
 $_ = 'x' x 20; 
-s/\d*|x/<$&>/g; 
+s/(\d*|x)/<$1>/g; 
 $foo = '<>' . ('<x><>' x 20) ;
 print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n");
 
@@ -362,98 +362,12 @@ s/\Ga/x/;
 print "not " unless $_ eq 'xaaaaaaaa';
 print "ok 79\n";
 
-$t = 'aaa';
-
-$_ = $t;
-@res = ();
-pos = 1;
-s/\Ga(?{push @res, $_, $`})/xx/g;
-print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa';
+$_ = 'aaaa';
+s/\ba/./g;
+print "#'$_'\nnot " unless $_ eq '.aaa';
 print "ok 80\n";
 
-$_ = $t;
-@res = ();
-pos = 1;
-s/\Ga(?{push @res, $_, $`})/x/g;
-print "not " unless "$_ @res" eq 'axx aaa a aaa aa';
-print "ok 81\n";
-
-$_ = $t;
-@res = ();
-pos = 1;
-s/\Ga(?{push @res, $_, $`})/xx/;
-print "not " unless "$_ @res" eq 'axxa aaa a';
-print "ok 82\n";
-
-$_ = $t;
-@res = ();
-pos = 1;
-s/\Ga(?{push @res, $_, $`})/x/;
-print "not " unless "$_ @res" eq 'axa aaa a';
-print "ok 83\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/xx/g;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
-print "ok 84\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/x/g;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
-print "ok 85\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/xx/;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
-print "ok 86\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/x/;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
-print "ok 87\n";
-
-sub x2 {'xx'}
-sub x1 {'x'}
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
-print "ok 88\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
-print "ok 89\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/x2/e;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
-print "ok 90\n";
-
-$a = $t;
-@res = ();
-pos ($a) = 1;
-$a =~ s/\Ga(?{push @res, $_, $`})/x1/e;
-print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
-print "ok 91\n";
-
 eval q% s/a/"b"}/e %;
-print ($@ =~ /Bad evalled substitution/ ? "ok 92\n" : "not ok 92\n");
+print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n");
 eval q% ($_ = "x") =~ s/(.)/"$1 "/e %;
-print +($_ eq "x " and !length $@) ? "ok 93\n" : "not ok 93\n# \$_ eq $_, $@\n";
-
-
+print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n";

diff --git a/t/op/subst_amp.t b/t/op/subst_amp.t
new file mode 100644 (file)
index 0000000..e5e31f5
--- /dev/null
+++ b/t/op/subst_amp.t
@@ -0,0 +1,104 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib' if -d '../lib';
+    require Config; import Config;
+}
+
+print "1..13\n";
+
+$_ = 'x' x 20; 
+s/\d*|x/<$&>/g; 
+$foo = '<>' . ('<x><>' x 20) ;
+print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n");
+
+$t = 'aaa';
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/xx/g;
+print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa';
+print "ok 2\n";
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/x/g;
+print "not " unless "$_ @res" eq 'axx aaa a aaa aa';
+print "ok 3\n";
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/xx/;
+print "not " unless "$_ @res" eq 'axxa aaa a';
+print "ok 4\n";
+
+$_ = $t;
+@res = ();
+pos = 1;
+s/\Ga(?{push @res, $_, $`})/x/;
+print "not " unless "$_ @res" eq 'axa aaa a';
+print "ok 5\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/xx/g;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
+print "ok 6\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x/g;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
+print "ok 7\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/xx/;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
+print "ok 8\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x/;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
+print "ok 9\n";
+
+sub x2 {'xx'}
+sub x1 {'x'}
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
+print "ok 10\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
+print "ok 11\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x2/e;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
+print "ok 12\n";
+
+$a = $t;
+@res = ();
+pos ($a) = 1;
+$a =~ s/\Ga(?{push @res, $_, $`})/x1/e;
+print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
+print "ok 13\n";
+