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.

1 files changed, 65 insertions, 33 deletions

diff --git a/toke.c b/toke.c
index c6dfef2b8a..015a415543 100644
--- 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;
 	}