make re_evals be seen by the toker/parser

This commit is a first step to making the handling of (/(?{...})/ more sane.
But see the big proviso at the end.

Currently a patten like /a(?{...})b/ is uninterpreted by the lexer and
parser, and is instead passed as-is to the regex compiler, which is
responsible for ensuring that the embedded perl code is extracted and
compiled. The only thing the quoted string code in the lexer currently
does is to skip nested matched {}'s, in order to get to end of the code
block and restart looking for interpolated variables, \Q etc.

This commit makes the lexer smarter.

Consider the following pattern:

    /FOO(?{BLOCK})BAR$var/

This is currently tokenised as

    op_match
    (
    op_const["FOO(?{BLOCK})BAR"]
    ,
    $
    "var"
    )

Instead, tokenise it as:

    op_match
    (
    op_const["FOO"]
    ,
    DO
    {
    BLOCK
    ;
    }
    ,
    op_const["(?{BLOCK})"]
    ,
    op_const["BAR"]
    ,
    $
    "var"
    )

This means that BLOCK is itself tokenised and parsed. We also insert
a const into the stream to include the original source text of BLOCK so
that it's available for stringifying qr's etc.

Note that by allowing the lexer/parser direct access to BLOCK, we can now
handle things like
    /(?{"{"})/

This mechanism is similar to the way something like

    "abc $a[foo(q(]))] def"

is currently parsed: the double-quoted string handler in the lexer stops
at $a[, the 'foo(q(]))' is treated as perl code, then at the end control is
passed back to the string handler to handle the ' def'.

This commit includes a new error message:

    Sequence (?{...}) not terminated with ')'

since when control is passed back to the quoted-string handler, it expects
to find the ')' as the next char. This new error mostly replaces the old

    Sequence (?{...}) not terminated or not {}-balanced in regex

Big proviso:

This commit updates toke.c to recognise the embedded code, but doesn't
then do anything with it. The parser will pass both a compiled do block
and a const for each embedded (?{..}), and Perl_pmruntime just throws
away the do block and keeps the constant text instead which is passed to
the regex compiler. So currently each code block gets compiled twice (!)
with two sets of warnings etc. The next stage will be to pass these do
blocks to the regex compiler.

This commit is based on a patch I had originally worked up about 6 years
ago and has been sitting bit-rotting ever since.

diff --git a/op.c b/op.c
index 400291a..d132f5b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4268,6 +4268,36 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
        cLISTOPx(expr)->op_last = kid;
     }
 
+    if (isreg && expr->op_type == OP_LIST) {
+       /* XXX tmp measure; strip all the DOs out and
+        * concatenate adjacent consts */
+       OP *o, *kid;
+       o = cLISTOPx(expr)->op_first;
+       while (o->op_sibling) {
+           kid = o->op_sibling;
+           if (kid->op_type == OP_NULL && (kid->op_flags & OPf_SPECIAL)) {
+               /* do {...} */
+               o->op_sibling = kid->op_sibling;
+               kid->op_sibling = NULL;
+               op_free(kid);
+           }
+           else if (o->op_type == OP_CONST && kid->op_type == OP_CONST){
+               SV* sv = cSVOPo->op_sv;
+               SvREADONLY_off(sv);
+               sv_catsv(sv, cSVOPx(kid)->op_sv);
+               SvREADONLY_on(sv);
+               o->op_sibling = kid->op_sibling;
+               kid->op_sibling = NULL;
+               op_free(kid);
+           }
+           else
+               o = o->op_sibling;
+       }
+       cLISTOPx(expr)->op_last = o;
+    }
+
+
+
     if (isreg && expr->op_type == OP_LIST &&
        cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
     {

diff --git a/perl.h b/perl.h
index 798e7b7..862f25c 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3470,6 +3470,7 @@ struct _sublex_info {
     OP *sub_op;                /* "lex_op" to use */
     char *super_bufptr;        /* PL_parser->bufptr that was */
     char *super_bufend;        /* PL_parser->bufend that was */
+    char *re_eval_start;/* start of "(?{..." text */
 };
 
 #include "parser.h"

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 5b5bbdb..cb814e3 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -4336,6 +4336,13 @@ must balance for Perl to detect the end of the clause properly.
 The <-- HERE shows in the regular expression about where the
 problem was discovered.  See L<perlre>.
 
+=item Sequence (?{...}) not terminated with ')'
+
+(F) If the contents of a (?{...}) clause contain braces, they must balance
+for Perl to detect the end of the clause properly. The <-- HERE shows in
+the regular expression about where the problem was discovered. See
+L<perlre>.
+
 =item Z<>500 Server error
 
 See Server error.

diff --git a/t/lib/strict/vars b/t/lib/strict/vars
index 87e5a77..6e3c1e9 100644 (file)
--- a/t/lib/strict/vars
+++ b/t/lib/strict/vars
@@ -517,7 +517,9 @@ Execution of - aborted due to compilation errors.
 # [perl #26910] hints not propagated into (?{...})
 use strict 'vars';
 qr/(?{$foo++})/;
+# XXX temp expect duplicate errors
 EXPECT
+Global symbol "$foo" requires explicit package name at - line 3.
 Global symbol "$foo" requires explicit package name at (re_eval 1) line 1.
 Compilation failed in regexp at - line 3.
 ########

diff --git a/t/op/blocks.t b/t/op/blocks.t
index e6c53d7..0717699 100644 (file)
--- a/t/op/blocks.t
+++ b/t/op/blocks.t
@@ -32,6 +32,10 @@ e1
                );
 my $expect = ":" . join(":", @expect);
 
+# XXX tmp while re-evals are being doubly compiled:
+$expect =
+ ':b1:b2:b3:b4:b6:b6:u5:b7:u6:u5:u1:c3:c2:c2:c1:i1:i2:b5:u2:u3:u4:e2:e1';
+
 fresh_perl_is(<<'SCRIPT', $expect,{switches => [''], stdin => '', stderr => 1 },'Order of execution of special blocks');
 BEGIN {print ":b1"}
 END {print ":e1"}

diff --git a/t/re/re_tests b/t/re/re_tests
index 3a35975..6952f30 100644 (file)
--- a/t/re/re_tests
+++ b/t/re/re_tests
@@ -534,12 +534,12 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace     y       $1$2    ce
 '(ab)\d\1'i    ab4Ab   y       $1      ab
 foo\w*\d{4}baz foobar1234baz   y       $&      foobar1234baz
 a(?{})b        cabd    y       $&      ab
-a(?{)b -       c       -       Sequence (?{...}) not terminated or not {}-balanced
-a(?{{})b       -       c       -       Sequence (?{...}) not terminated or not {}-balanced
+a(?{f()+       -       c       -       Missing right curly or square bracket
+a(?{{1}+       -       c       -       Missing right curly or square bracket
 a(?{}})b       -       c       -       
 a(?{"{"})b     -       c       -       Sequence (?{...}) not terminated or not {}-balanced
 a(?{"\{"})b    cabd    y       $&      ab
-a(?{"{"}})b    -       c       -       Unmatched right curly bracket
+a(?{"{"}})b    -       c       -       Sequence (?{...}) not terminated with ')'
 a(?{$::bl="\{"}).b     caxbd   y       $::bl   {
 x(~~)*(?:(?:F)?)?      x~~     y       -       -
 ^a(?#xxx){3}c  aaac    y       $&      aaac

diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t
index d6b343b..476db59 100644 (file)
--- a/t/re/reg_mesg.t
+++ b/t/re/reg_mesg.t
@@ -39,7 +39,7 @@ my @death =
 
  '/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/',
 
- '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/',
+ '/(?{ 1/' => 'Missing right curly or square bracket',
 
  '/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/',
 

diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t
index 9c76a64..e1ffc1b 100644 (file)
--- a/t/run/fresh_perl.t
+++ b/t/run/fresh_perl.t
@@ -355,9 +355,7 @@ Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE
 ########
 /(?{"{"}})/    # Check it outside of eval too
 EXPECT
-Unmatched right curly bracket at (re_eval 1) line 1, at end of line
-syntax error at (re_eval 1) line 1, near ""{"}"
-Compilation failed in regexp at - line 1.
+Sequence (?{...}) not terminated with ')' at - line 1.
 ########
 BEGIN { @ARGV = qw(a b c d e) }
 BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }

diff --git a/toke.c b/toke.c
index c6dfef2..015a415 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -148,6 +148,9 @@ static const char ident_too_long[] = "Identifier too long";
 /* LEX_* are values for PL_lex_state, the state of the lexer.
  * They are arranged oddly so that the guard on the switch statement
  * can get by with a single comparison (if the compiler is smart enough).
+ *
+ * These values refer to the various states within a sublex parse,
+ * i.e. within a double quotish string
  */
 
 /* #define LEX_NOTPARSING              11 is done in perl.h. */
@@ -2446,6 +2449,7 @@ S_sublex_push(pTHX)
     SAVEI32(PL_lex_casemods);
     SAVEI32(PL_lex_starts);
     SAVEI8(PL_lex_state);
+    SAVEPPTR(PL_sublex_info.re_eval_start);
     SAVEVPTR(PL_lex_inpat);
     SAVEI16(PL_lex_inwhat);
     SAVECOPLINE(PL_curcop);
@@ -2462,6 +2466,7 @@ S_sublex_push(pTHX)
 
     PL_linestr = PL_lex_stuff;
     PL_lex_stuff = NULL;
+    PL_sublex_info.re_eval_start = NULL;
 
     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
        = SvPVX(PL_linestr);
@@ -2571,8 +2576,11 @@ S_sublex_done(pTHX)
 /*
   scan_const
 
-  Extracts a pattern, double-quoted string, or transliteration.  This
-  is terrifying code.
+  Extracts the next constant part of a pattern, double-quoted string,
+  or transliteration.  This is terrifying code.
+
+  For example, in parsing the double-quoted string "ab\x63$d", it would
+  stop at the '$' and return an OP_CONST containing 'abc'.
 
   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
   processing a pattern (PL_lex_inpat is true), a transliteration
@@ -2580,15 +2588,22 @@ S_sublex_done(pTHX)
 
   Returns a pointer to the character scanned up to. If this is
   advanced from the start pointer supplied (i.e. if anything was
-  successfully parsed), will leave an OP for the substring scanned
+  successfully parsed), will leave an OP_CONST for the substring scanned
   in pl_yylval. Caller must intuit reason for not parsing further
   by looking at the next characters herself.
 
   In patterns:
-    backslashes:
-      constants: \N{NAME} only
-      case and quoting: \U \Q \E
-    stops on @ and $, but not for $ as tail anchor
+    expand:
+      \N{ABC}  => \N{U+41.42.43}
+
+    pass through:
+       all other \-char, including \N and \N{ apart from \N{ABC}
+
+    stops on:
+       @ and $ where it appears to be a var, but not for $ as tail anchor
+        \l \L \u \U \Q \E
+       (?{  or  (??{
+
 
   In transliterations:
     characters are VERY literal, except for - not at the start or end
@@ -2618,7 +2633,7 @@ S_sublex_done(pTHX)
   it's a tail anchor if $ is the last thing in the string, or if it's
   followed by one of "()| \r\n\t"
 
-  \1 (backreferences) are turned into $1
+  \1 (backreferences) are turned into $1 in substitutions
 
   The structure of the code is
       while (there's a character to process) {
@@ -2846,8 +2861,10 @@ S_scan_const(pTHX_ char *start)
 
        /* if we get here, we're not doing a transliteration */
 
-       /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
-          except for the last char, which will be done separately. */
+       /* skip for regexp comments /(?#comment)/, except for the last
+        * char, which will be done separately.
+        * Stop on (?{..}) and friends */
+
        else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
            if (s[2] == '#') {
                while (s+1 < send && *s != ')')
@@ -2856,23 +2873,7 @@ S_scan_const(pTHX_ char *start)
            else if (s[2] == '{' /* This should match regcomp.c */
                    || (s[2] == '?' && s[3] == '{'))
            {
-               I32 count = 1;
-               char *regparse = s + (s[2] == '{' ? 3 : 4);
-               char c;
-
-               while (count && (c = *regparse)) {
-                   if (c == '\\' && regparse[1])
-                       regparse++;
-                   else if (c == '{')
-                       count++;
-                   else if (c == '}')
-                       count--;
-                   regparse++;
-               }
-               if (*regparse != ')')
-                   regparse--;         /* Leave one char for continuation. */
-               while (s < regparse)
-                   *d++ = NATIVE_TO_NEED(has_utf8,*s++);
+               break;
            }
        }
 
@@ -2883,6 +2884,10 @@ S_scan_const(pTHX_ char *start)
                *d++ = NATIVE_TO_NEED(has_utf8,*s++);
        }
 
+       /* no further processing of single-quoted regex */
+       else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
+           goto default_action;
+
        /* check for embedded arrays
           (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
           */
@@ -3552,6 +3557,9 @@ S_scan_const(pTHX_ char *start)
            } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
                type = "s";
                typelen = 1;
+           } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
+               type = "q";
+               typelen = 1;
            } else  {
                type = "qq";
                typelen = 2;
@@ -4611,7 +4619,7 @@ Perl_yylex(pTHX)
     case LEX_INTERPSTART:
        if (PL_bufptr == PL_bufend)
            return REPORT(sublex_done());
-       DEBUG_T({ PerlIO_printf(Perl_debug_log,
+       DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
               "### Interpolated variable\n"); });
        PL_expect = XTERM;
        PL_lex_dojoin = (*PL_bufptr == '@');
@@ -4632,6 +4640,16 @@ Perl_yylex(pTHX)
            NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
            force_next(FUNC);
        }
+       /* Convert (?{...}) and friends to 'do {...}' */
+       if (PL_lex_inpat && *PL_bufptr == '(') {
+           PL_sublex_info.re_eval_start = PL_bufptr;
+           PL_bufptr += 2;
+           if (*PL_bufptr != '{')
+               PL_bufptr++;
+           PL_expect = XTERMBLOCK;
+           force_next(DO);
+       }
+
        if (PL_lex_starts++) {
            s = PL_bufptr;
 #ifdef PERL_MAD
@@ -4677,6 +4695,22 @@ Perl_yylex(pTHX)
                Perl_croak(aTHX_ "Bad evalled substitution pattern");
            PL_lex_repl = NULL;
        }
+       if (PL_sublex_info.re_eval_start) {
+           if (*PL_bufptr != ')')
+               Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
+           PL_bufptr++;
+           /* having compiled a (?{..}) expression, return the original
+            * text too, as a const */
+           PL_nextval[PL_nexttoke].opval =
+                   (OP*)newSVOP(OP_CONST, 0,
+                       newSVpvn(PL_sublex_info.re_eval_start,
+                               PL_bufptr - PL_sublex_info.re_eval_start));
+           force_next(THING);
+           PL_sublex_info.re_eval_start = NULL;
+           PL_expect = XTERM;
+           return REPORT(',');
+       }
+
        /* FALLTHROUGH */
     case LEX_INTERPCONCAT:
 #ifdef DEBUGGING
@@ -4687,12 +4721,10 @@ Perl_yylex(pTHX)
        if (PL_bufptr == PL_bufend)
            return REPORT(sublex_done());
 
-       if (SvIVX(PL_linestr) == '\'') {
+       /* m'foo' still needs to be parsed for possible (?{...}) */
+       if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
            SV *sv = newSVsv(PL_linestr);
-           if (!PL_lex_inpat)
-               sv = tokeq(sv);
-           else if ( PL_hints & HINT_NEW_RE )
-               sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
+           sv = tokeq(sv);
            pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
            s = PL_bufend;
        }