[perl #120463] s/// and tr/// with wide delimiters

$ perl -Mutf8 -e 's αaαα'
Substitution replacement not terminated at -e line 1.

What is happening is that the first scan goes past the delimiter at
the end of the pattern.  Then a single byte is compared (the previous
character against the first byte of the opening delimiter) to see
whether the parser needs to step back one byte before scanning the
second part.

That means you can do the equivalent of s/foo/|bar|g if / is replaced
with a wide character:

$ perl -l -Mutf8 -e '$_ = "a";  s αaα|b|; print'
b

This commit fixes it by giving toke.c:S_scan_str an extra parameter,
so it can tell the callers that need this (scan_subst and scan_trans)
where to start scanning the replacement.

diff --git a/embed.fnc b/embed.fnc
index e6915f8..aa14251 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2270,7 +2270,8 @@ sR        |char*  |scan_inputsymbol|NN char *start
 sR     |char*  |scan_pat       |NN char *start|I32 type
 sR     |char*  |scan_str       |NN char *start|int keep_quoted \
                                |int keep_delims|int re_reparse \
-                               |bool deprecate_escaped_matching
+                               |bool deprecate_escaped_matching \
+                               |NULLOK char **delimp
 sR     |char*  |scan_subst     |NN char *start
 sR     |char*  |scan_trans     |NN char *start
 s      |char*  |scan_word      |NN char *s|NN char *dest|STRLEN destlen \

diff --git a/embed.h b/embed.h
index 29ce7b9..c042eab 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1648,7 +1648,7 @@
 #define scan_ident(a,b,c,d)    S_scan_ident(aTHX_ a,b,c,d)
 #define scan_inputsymbol(a)    S_scan_inputsymbol(aTHX_ a)
 #define scan_pat(a,b)          S_scan_pat(aTHX_ a,b)
-#define scan_str(a,b,c,d,e)    S_scan_str(aTHX_ a,b,c,d,e)
+#define scan_str(a,b,c,d,e,f)  S_scan_str(aTHX_ a,b,c,d,e,f)
 #define scan_subst(a)          S_scan_subst(aTHX_ a)
 #define scan_trans(a)          S_scan_trans(aTHX_ a)
 #define scan_word(a,b,c,d,e)   S_scan_word(aTHX_ a,b,c,d,e)

diff --git a/proto.h b/proto.h
index f8e7631..da3bbb9 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -7497,7 +7497,7 @@ STATIC char*      S_scan_pat(pTHX_ char *start, I32 type)
 #define PERL_ARGS_ASSERT_SCAN_PAT      \
        assert(start)
 
-STATIC char*   S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, bool deprecate_escaped_matching)
+STATIC char*   S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, bool deprecate_escaped_matching, char **delimp)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SCAN_STR      \

diff --git a/t/uni/lex_utf8.t b/t/uni/lex_utf8.t
index 368185f..d6c6261 100644 (file)
--- a/t/uni/lex_utf8.t
+++ b/t/uni/lex_utf8.t
@@ -5,6 +5,8 @@
 BEGIN {
     $| = 1;
 
+    chdir 't';
+    @INC = '../lib';
     require './test.pl';
     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
     skip_all('EBCDIC') if $::IS_EBCDIC;
@@ -12,7 +14,7 @@ BEGIN {
 
 use strict;
 
-plan (tests => 11);
+plan (tests => 15);
 use charnames ':full';
 
 use utf8;
@@ -48,5 +50,16 @@ do {
     unlike $@, qr/utf8_heavy/,
        'No utf8_heavy errors with our() syntax errors';
 }
+
+# [perl #120463]
+$_ = "a";
+eval 's αaαbα';
+is $@, "", 's/// compiles, where / is actually a wide character';
+is $_, "b", 'substitution worked';
+$_ = "a";
+eval 'tr νaνbν';
+is $@, "", 'y/// compiles, where / is actually a wide character';
+is $_, "b", 'transliteration worked';
+
 __END__
 

diff --git a/toke.c b/toke.c
index ae248f2..cd653dd 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -5945,7 +5945,7 @@ Perl_yylex(pTHX)
                }
                sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
                if (*d == '(') {
-                   d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
+                   d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL);
                    COPLINE_SET_FROM_MULTI_END;
                    if (!d) {
                        /* MUST advance bufptr here to avoid bogus
@@ -6842,7 +6842,7 @@ Perl_yylex(pTHX)
        TERM(THING);
 
     case '\'':
-       s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        COPLINE_SET_FROM_MULTI_END;
        DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
        if (PL_expect == XOPERATOR) {
@@ -6858,7 +6858,7 @@ Perl_yylex(pTHX)
        TERM(sublex_start());
 
     case '"':
-       s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        DEBUG_T( {
            if (s)
                printbuf("### Saw string before %s\n", s);
@@ -6889,7 +6889,7 @@ Perl_yylex(pTHX)
        TERM(sublex_start());
 
     case '`':
-       s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
        if (PL_expect == XOPERATOR)
            no_op("Backticks",s);
@@ -8373,7 +8373,7 @@ Perl_yylex(pTHX)
            LOP(OP_PIPE_OP,XTERM);
 
        case KEY_q:
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            COPLINE_SET_FROM_MULTI_END;
            if (!s)
                missingterm(NULL);
@@ -8385,7 +8385,7 @@ Perl_yylex(pTHX)
 
        case KEY_qw: {
            OP *words = NULL;
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            COPLINE_SET_FROM_MULTI_END;
            if (!s)
                missingterm(NULL);
@@ -8436,7 +8436,7 @@ Perl_yylex(pTHX)
        }
 
        case KEY_qq:
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            if (!s)
                missingterm(NULL);
            pl_yylval.ival = OP_STRINGIFY;
@@ -8449,7 +8449,7 @@ Perl_yylex(pTHX)
            TERM(sublex_start());
 
        case KEY_qx:
-           s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+           s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
            if (!s)
                missingterm(NULL);
            pl_yylval.ival = OP_BACKTICK;
@@ -8766,7 +8766,7 @@ Perl_yylex(pTHX)
 
                /* Look for a prototype */
                if (*s == '(') {
-                   s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+                   s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
                    COPLINE_SET_FROM_MULTI_END;
                    if (!s)
                        Perl_croak(aTHX_ "Prototype not terminated");
@@ -9692,7 +9692,7 @@ S_scan_pat(pTHX_ char *start, I32 type)
     PERL_ARGS_ASSERT_SCAN_PAT;
 
     s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
-                       TRUE /* look for escaped bracketed metas */ );
+                       TRUE /* look for escaped bracketed metas */, NULL);
 
     if (!s) {
        const char * const delimiter = skipspace(start);
@@ -9780,19 +9780,19 @@ S_scan_subst(pTHX_ char *start)
 #ifdef PERL_MAD
     char *modstart;
 #endif
+    char *t;
 
     PERL_ARGS_ASSERT_SCAN_SUBST;
 
     pl_yylval.ival = OP_NULL;
 
     s = scan_str(start,!!PL_madskills,FALSE,FALSE,
-                 TRUE /* look for escaped bracketed metas */ );
+                 TRUE /* look for escaped bracketed metas */, &t);
 
     if (!s)
        Perl_croak(aTHX_ "Substitution pattern not terminated");
 
-    if (s[-1] == PL_multi_open)
-       s--;
+    s = t;
 #ifdef PERL_MAD
     if (PL_madskills) {
        CURMAD('q', PL_thisopen);
@@ -9805,7 +9805,7 @@ S_scan_subst(pTHX_ char *start)
 
     first_start = PL_multi_start;
     first_line = CopLINE(PL_curcop);
-    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
     if (!s) {
        if (PL_lex_stuff) {
            SvREFCNT_dec(PL_lex_stuff);
@@ -9892,17 +9892,17 @@ S_scan_trans(pTHX_ char *start)
 #ifdef PERL_MAD
     char *modstart;
 #endif
+    char *t;
 
     PERL_ARGS_ASSERT_SCAN_TRANS;
 
     pl_yylval.ival = OP_NULL;
 
-    s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t);
     if (!s)
        Perl_croak(aTHX_ "Transliteration pattern not terminated");
 
-    if (s[-1] == PL_multi_open)
-       s--;
+    s = t;
 #ifdef PERL_MAD
     if (PL_madskills) {
        CURMAD('q', PL_thisopen);
@@ -9913,7 +9913,7 @@ S_scan_trans(pTHX_ char *start)
     }
 #endif
 
-    s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+    s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
     if (!s) {
        if (PL_lex_stuff) {
            SvREFCNT_dec(PL_lex_stuff);
@@ -10366,7 +10366,7 @@ S_scan_inputsymbol(pTHX_ char *start)
 
     if (d - PL_tokenbuf != len) {
        pl_yylval.ival = OP_GLOB;
-       s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+       s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
        if (!s)
           Perl_croak(aTHX_ "Glob not terminated");
        return s;
@@ -10466,6 +10466,11 @@ intro_sym:
        deprecate_escaped_meta  issue a deprecation warning for cer-
                                tain paired metacharacters that appear
                                escaped within it
+       delimp                  if non-null, this is set to the position of
+                               the closing delimiter, or just after it if
+                               the closing and opening delimiters differ
+                               (i.e., the opening delimiter of a substitu-
+                               tion replacement)
    returns: position to continue reading from buffer
    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
        updates the read buffer.
@@ -10507,7 +10512,7 @@ intro_sym:
 
 STATIC char *
 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
-                bool deprecate_escaped_meta
+                bool deprecate_escaped_meta, char **delimp
     )
 {
     dVAR;
@@ -10934,6 +10939,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
        PL_sublex_info.repl = sv;
     else
        PL_lex_stuff = sv;
+    if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
     return s;
 }