Mostly complete fix for literal /(?{..})/ blocks

Change the way that code blocks in patterns are parsed and executed,
especially as regards lexical and scoping behaviour.

(Note that this fix only applies to literal code blocks appearing within
patterns: run-time patterns, and literals within qr//, are still done the
old broken way for now).

This change means that for literal /(?{..})/ and /(??{..})/:

* the code block is now fully parsed in the same pass as the surrounding
  code, which means that the compiler no longer just does a simplistic
  count of balancing {} to find the limits of the code block;
  i.e. stuff like /(?{  $x = "{" })/ now works (in the same way
  that subscripts in double quoted strings always have: "$a{'{'}" )

* Error and warning messages will now appear to emanate from the main body
  rather than an re_eval; e.g. the output from

    #!/usr/bin/perl
    /(?{ warn "boo" })/

has changed from

    boo at (re_eval 1) line 1.

to

    boo at /tmp/p line 2.

* scope and closures now behave as you might expect; for example

        for my $x (qw(a b c)) { "" =~ /(?{ print $x })/ }

  now prints "abc" rather than ""

* with recursion, it now finds the lexical within the appropriate depth
  of pad: this code now prints "012" rather than "000":

    sub recurse {
        my ($n) = @_;
        return if $n > 2;
        "" =~ /^(?{print $n})/;
        recurse($n+1);
    }
    recurse(0);

* an earlier fix that stopped 'my' declarations within code blocks causing
  crashes, required the accumulating of two SAVECOMPPADs on the stack for
  each iteration of the code block; this is no longer needed;

* UNITCHECK blocks within literal code blocks are now run as part of the
  main body of code (run-time code blocks still trigger an immediate
  call to the UNITCHECK block though)

This is all achieved by building upon the efforts of the commits which led
up to this; those altered the parser to parse literal code blocks
directly, but up until now those code blocks were discarded by
Perl_pmruntime and the block re-compiled using the original re_eval
mechanism. As of this commit, for the non-qr and non-runtime variants,
those code blocks are no longer thrown away. Instead:

* the LISTOP generated by the parser, which contains all the code
  blocks plus OP_CONSTs that collectively make up the literal pattern,
  is now stored in a new field in PMOPs, called op_code_list. For example
  in /A(?{BLOCK})C/, the listop stored in op_code_list looks like

    LIST
        PUSHMARK
        CONST['A']
        NULL/special (aka a DO block)
            BLOCK
        CONST['(?{BLOCK})']
        CONST['B']

* each of the code blocks has its last op set to null and is individually
  run through the peephole optimiser, so each one becomes a little
  self-contained block of code, rather than a list of blocks that run into
  each other;

* then in re_op_compile(), we concatenate the list of CONSTs to produce a
  string to be compiled, but at the same time we note any DO blocks and
  note the start and end positions of the corresponding CONST['(?{BLOCK})'];

* (if the current regex engine isn't the built-in perl one, then we just
  throw away the code blocks and pass the concatenated string to the engine)

* then during regex compilation, whenever we encounter a '(?{', we see if
  it matches the index of one of the pre-compiled blocks, and if so, we
  store a pointer to that block in an 'l' data slot, and use the end index
  to skip over the text of the code body. Conversely, if the index doesn't
  match, then we know that it's a run-time pattern and (for now), compile
  it in the old way.

* During execution, when an EVAL op is encountered, if data->what is 'l',
  then we just use the pad that was in effect when the pattern was called;
  i.e. we use the current pad slot of the currently executing CV that the
  pattern is embedded within.

1 files changed, 71 insertions, 30 deletions

diff --git a/op.c b/op.c
index 5cc98874ae..4d82c7cc57 100644
--- a/op.c
+++ b/op.c
@@ -743,6 +743,8 @@ Perl_op_clear(pTHX_ OP *o)
     case OP_MATCH:
     case OP_QR:
 clear_pmop:
+	op_free(cPMOPo->op_code_list);
+	cPMOPo->op_code_list = NULL;
 	forget_pmop(cPMOPo, 1);
 	cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
         /* we use the same protection as the "SAFE" version of the PM_ macros
@@ -4299,45 +4301,83 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 		is_compiletime = 0;
 	}
     }
-    else { assert(expr->op_type != OP_PUSHMARK); if (expr->op_type != OP_CONST && expr->op_type != OP_PUSHMARK)
+    else if (expr->op_type != OP_CONST)
 	is_compiletime = 0;
-    }
 
    /* are we using an external (non-perl) re engine? */
 
    eng = current_re_engine();
    ext_eng = (eng &&  eng != &PL_core_reg_engine);
 
-    /* concatenate adjacent CONSTs, and for non-perl engines, strip out
-     * any DO blocks */
+    /* for perl engine:
+     *   concatenate adjacent CONSTs for non-code case
+     *   pre-process DO blocks;
+     * for non-perl engines:
+     *    concatenate adjacent CONSTs;
+     *    strip out any DO blocks
+     */
 
-    if (expr->op_type == OP_LIST
-	&& (!is_compiletime || /* XXX TMP until we handle runtime (?{}) */
-	   !has_code || ext_eng))
-    {
-	OP *o, *kid;
-	o = cLISTOPx(expr)->op_first;
-	while (o->op_sibling) {
-	    kid = o->op_sibling;
+    if (expr->op_type == OP_LIST) {
+	OP *kid, *okid = NULL;
+	kid = cLISTOPx(expr)->op_first;
+	while (kid) {
 	    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);
+		if (ext_eng  || !is_compiletime/*XXX tmp*/
+			|| o->op_type == OP_QR/*XXX tmp*/) {
+		    assert(okid);
+		    okid->op_sibling = kid->op_sibling;
+		    kid->op_sibling = NULL;
+		    op_free(kid);
+		    kid = okid;
+		}
+		else {
+		    /* treat each DO block as a separate little sub */
+		    scalar(kid);
+		    LINKLIST(kid);
+		    if (kLISTOP->op_first->op_type == OP_LEAVE) {
+			LISTOP *leave = cLISTOPx(kLISTOP->op_first);
+			/* skip ENTER */
+			assert(leave->op_first->op_type == OP_ENTER);
+			assert(leave->op_first->op_sibling);
+			kid->op_next = leave->op_first->op_sibling;
+			/* skip LEAVE */
+			assert(leave->op_flags & OPf_KIDS);
+			assert(leave->op_last->op_next = (OP*)leave);
+			leave->op_next = NULL; /* stop on last op */
+			op_null((OP*)leave);
+		    }
+		    else {
+			/* skip SCOPE */
+			OP *scope = kLISTOP->op_first;
+			assert(scope->op_type == OP_SCOPE);
+			assert(scope->op_flags & OPf_KIDS);
+			scope->op_next = NULL; /* stop on last op */
+			op_null(scope);
+		    }
+		    CALL_PEEP(kid);
+		    finalize_optree(kid);
+		}
 	    }
-	    else if (o->op_type == OP_CONST && kid->op_type == OP_CONST){
-		SV* sv = cSVOPo->op_sv;
+	    else if ( (ext_eng || !has_code || !is_compiletime/*XXX tmp*/)
+			      && kid->op_type == OP_CONST
+			      && kid->op_sibling
+	                      && kid->op_sibling->op_type == OP_CONST)
+	    {
+		OP *o = kid->op_sibling;
+		SV* sv = cSVOPx_sv(kid);
 		SvREADONLY_off(sv);
-		sv_catsv(sv, cSVOPx(kid)->op_sv);
+		sv_catsv(sv, cSVOPo_sv);
 		SvREADONLY_on(sv);
-		o->op_sibling = kid->op_sibling;
-		kid->op_sibling = NULL;
-		op_free(kid);
+		kid->op_sibling = o->op_sibling;
+		o->op_sibling = NULL;
+		op_free(o);
+		kid = okid;
 	    }
-	    else
-		o = o->op_sibling;
+	    okid = kid;
+	    kid = kid->op_sibling;
 	}
-	cLISTOPx(expr)->op_last = o;
+	cLISTOPx(expr)->op_last = okid;
     }
 
     PL_hints |= HINT_BLOCK_SCOPE;
@@ -4375,15 +4415,16 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 	    }
 
 	    PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
-	}
-	else
-	    PM_SETRE(pm, re_op_compile(NULL, expr, pm_flags));
-
 #ifdef PERL_MAD
-	op_getmad(expr,(OP*)pm,'e');
+	    op_getmad(expr,(OP*)pm,'e');
 #else
-	op_free(expr);
+	    op_free(expr);
 #endif
+	}
+	else {
+	    pm->op_code_list = expr;
+	    PM_SETRE(pm, re_op_compile(NULL, expr, pm_flags));
+	}
     }
     else {
 	bool reglist;