U8 hasargs = 0 /* used by PUSHSUB */
#define PUSH_MULTICALL(the_cv) \
+ PUSH_MULTICALL_WITHDEPTH(the_cv, 1);
+
+/* Like PUSH_MULTICALL, but allows you to specify the CvDEPTH increment,
+ * rather than the default of 1 (this isn't part of the public API) */
+
+#define PUSH_MULTICALL_WITHDEPTH(the_cv, depth) \
STMT_START { \
CV * const _nOnclAshIngNamE_ = the_cv; \
CV * const cv = _nOnclAshIngNamE_; \
PUSHSTACKi(PERLSI_SORT); \
PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \
PUSHSUB(cx); \
- if (++CvDEPTH(cv) >= 2) { \
+ CvDEPTH(cv) += depth; \
+ if (CvDEPTH(cv) >= 2) { \
PERL_STACK_OVERFLOW_CHECK(); \
Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
} \
#define POP_MULTICALL \
STMT_START { \
- if (! --CvDEPTH(multicall_cv)) \
- LEAVESUB(multicall_cv); \
+ if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) { \
+ LEAVESUB(multicall_cv); \
+ } \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
SPAGAIN; \
} STMT_END
+/* Change the CV of an already-pushed MULTICALL CxSUB block.
+ * (this isn't part of the public API) */
+
+#define CHANGE_MULTICALL_WITHDEPTH(the_cv, depth) \
+ STMT_START { \
+ CV * const _nOnclAshIngNamE_ = the_cv; \
+ CV * const cv = _nOnclAshIngNamE_; \
+ AV * const padlist = CvPADLIST(cv); \
+ cx = &cxstack[cxstack_ix]; \
+ assert(cx->cx_type & CXp_MULTICALL); \
+ if (! ((CvDEPTH(multicall_cv) = cx->blk_sub.olddepth)) ) { \
+ LEAVESUB(multicall_cv); \
+ } \
+ cx->cx_type &= ~CXp_HASARGS; \
+ PUSHSUB(cx); \
+ CvDEPTH(cv) += depth; \
+ if (CvDEPTH(cv) >= 2) { \
+ PERL_STACK_OVERFLOW_CHECK(); \
+ Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
+ } \
+ SAVECOMPPAD(); \
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
+ multicall_cv = cv; \
+ multicall_cop = CvSTART(cv); \
+ } STMT_END
/*
* Local variables:
* c-indentation-style: bsd
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
- if (isGV(cvgv)) {
+ if (cvgv && isGV(cvgv)) {
SV * const sv = newSV(0);
gv_efullname3(sv, cvgv, NULL);
mPUSHs(sv);
MAGIC *mg;
PL_reg_state.re_state_eval_setup_done = TRUE;
- DEBUG_EXECUTE_r(DEBUG_s(
- PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
- (IV)(PL_stack_sp - PL_stack_base));
- ));
- SAVESTACK_CXPOS();
- cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
- /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
- SAVETMPS;
- /* Apparently this is not needed, judging by wantarray. */
- /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
- cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
-
if (reginfo->sv) {
/* Make $_ available to executed code. */
if (reginfo->sv != DEFSV) {
false: plain (?=foo)
true: used as a condition: (?(?=foo))
*/
- PAD* const initial_pad = PL_comppad;
+ PAD* last_pad = NULL;
+ dMULTICALL;
+ I32 gimme = G_SCALAR;
+ CV *caller_cv = NULL; /* who called us */
+ CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
+
#ifdef DEBUGGING
GET_RE_DEBUG_FLAGS_DECL;
#endif
+ /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
+ multicall_oldcatch = 0;
+ multicall_cv = NULL;
+ cx = NULL;
+
+
PERL_ARGS_ASSERT_REGMATCH;
DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
}
{
/* execute the code in the {...} */
+
dSP;
- SV ** const before = SP;
+ SV ** before;
OP * const oop = PL_op;
COP * const ocurcop = PL_curcop;
- PAD *old_comppad, *new_comppad;
+ OP *nop;
char *saved_regeol = PL_regeol;
struct re_save_state saved_state;
+ CV *newcv;
/* To not corrupt the existing regex state while executing the
* eval we would normally put it on the save stack, like with
* variable.
*/
Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
+
PL_reg_state.re_reparsing = FALSE;
+ if (!caller_cv)
+ caller_cv = find_runcv(NULL);
+
n = ARG(scan);
+
if (rexi->data->what[n] == 'r') { /* code from an external qr */
- /* XXX assumes pad depth is 1; this isn't necessarily
- * the case with recursive qr//'s */
- new_comppad = (PAD*)AvARRAY(CvPADLIST(
- ((struct regexp *)SvANY(
+ newcv = ((struct regexp *)SvANY(
(REGEXP*)(rexi->data->data[n])
))->qr_anoncv
- ))[1];
- PL_op = (OP*)rexi->data->data[n+1];
+ ;
+ nop = (OP*)rexi->data->data[n+1];
}
else if (rexi->data->what[n] == 'l') { /* literal code */
- new_comppad = initial_pad; /* the pad of the current sub */
- PL_op = (OP*)rexi->data->data[n];
+ newcv = caller_cv;
+ nop = (OP*)rexi->data->data[n];
+ assert(CvDEPTH(newcv));
}
else {
/* literal with own CV */
assert(rexi->data->what[n] == 'L');
- new_comppad = (PAD*)AvARRAY(CvPADLIST(rex->qr_anoncv))[1];
- PL_op = (OP*)rexi->data->data[n];
+ newcv = rex->qr_anoncv;
+ nop = (OP*)rexi->data->data[n];
}
+
/* the initial nextstate you would normally execute
* at the start of an eval (which would cause error
* messages to come from the eval), may be optimised
* away from the execution path in the regex code blocks;
* so manually set PL_curcop to it initially */
{
- OP *o = cUNOPx(PL_op)->op_first;
+ OP *o = cUNOPx(nop)->op_first;
assert(o->op_type == OP_NULL);
if (o->op_targ == OP_SCOPE) {
o = cUNOPo->op_first;
PL_curcop = (COP*)o;
}
}
- PL_op = PL_op->op_next;
+ nop = nop->op_next;
DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
- " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(PL_op)) );
- /* wrap the call in two SAVECOMPPADs. This ensures that
- * when the save stack is eventually unwound, all the
- * accumulated SAVEt_CLEARSV's will be processed with
- * interspersed SAVEt_COMPPAD's to ensure that lexicals
- * are cleared in the right pad */
- if (PL_comppad == new_comppad)
- old_comppad = new_comppad;
- else {
- SAVECOMPPAD();
- PAD_SAVE_LOCAL(old_comppad, new_comppad);
+ " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
+
+ /* normally if we're about to execute code from the same
+ * CV that we used previously, we just use the existing
+ * CX stack entry. However, its possible that in the
+ * meantime we may have backtracked, popped from the save
+ * stack, and undone the SAVECOMPPAD(s) associated with
+ * PUSH_MULTICALL; in which case PL_comppad no longer
+ * points to newcv's pad. */
+ if (newcv != last_pushed_cv || PL_comppad != last_pad)
+ {
+ I32 depth = (newcv == caller_cv) ? 0 : 1;
+ if (last_pushed_cv) {
+ CHANGE_MULTICALL_WITHDEPTH(newcv, depth);
+ }
+ else {
+ PUSH_MULTICALL_WITHDEPTH(newcv, depth);
+ }
+ last_pushed_cv = newcv;
}
+ last_pad = PL_comppad;
+
PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
if (sv_yes_mark) {
sv_setsv(sv_mrk, sv_yes_mark);
}
+ /* we don't use MULTICALL here as we want to call the
+ * first op of the block of interest, rather than the
+ * first op of the sub */
+ before = SP;
+ PL_op = nop;
CALLRUNOPS(aTHX); /* Scalar context. */
SPAGAIN;
if (SP == before)
Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
+ /* *** Note that at this point we don't restore
+ * PL_comppad, (or pop the CxSUB) on the assumption it may
+ * be used again soon. This is safe as long as nothing
+ * in the regexp code uses the pad ! */
PL_op = oop;
- if (old_comppad != PL_comppad) {
- SAVECOMPPAD();
- PAD_RESTORE_LOCAL(old_comppad);
- }
PL_curcop = ocurcop;
PL_regeol = saved_regeol;
if (!logical) {
sv_setsv(sv_mrk, sv_yes_mark);
}
+
+ if (last_pushed_cv) {
+ dSP;
+ POP_MULTICALL;
+ }
+
/* clean up; in particular, free all slabs above current one */
LEAVE_SCOPE(oldsave);
}
-plan tests => 427; # Update this when adding/deleting tests.
+plan tests => 434; # Update this when adding/deleting tests.
run_tests() unless caller;
like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
}
+ # jumbo test for:
+ # * recursion;
+ # * mixing all the different types of blocks (literal, qr/literal/,
+ # runtime);
+ # * backtracking (the Z+ alternation ensures CURLYX and full
+ # scope popping on backtracking)
+
+ {
+ sub recurse2 {
+ my ($depth)= @_;
+ return unless $depth;
+ my $s1 = '3-LMN';
+ my $r1 = qr/(??{"$s1-$depth"})/;
+
+ my $s2 = '4-PQR';
+ my $c1 = '(??{"$s2-$depth"})';
+ use re 'eval';
+ ok( "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+ . "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+ =~
+ /^<(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>
+ <(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>$/x,
+ "recurse2($depth)");
+ recurse2($depth-1);
+ }
+ recurse2(5);
+ }
+
+ # make sure that errors during compiling run-time code get trapped
+
+ {
+ use re 'eval';
+
+ my $code = '(?{$x=})';
+ eval { "a" =~ /^a$code/ };
+ like($@, qr/syntax error at \(eval \d+\) line \d+/, 'syntax error');
+
+ $code = '(?{BEGIN{die})';
+ eval { "a" =~ /^a$code/ };
+ like($@,
+ qr/BEGIN failed--compilation aborted at \(eval \d+\) line \d+/,
+ 'syntax error');
+ }
+
+
} # End of sub run_tests
1;
skip_all_if_miniperl("no dynamic loading on miniperl, no re");
}
-plan 18;
-
-# Functions for turning to-do-ness on and off (as there are so many
-# to-do tests)
-sub on { $::TODO = "(?{}) implementation is screwy" }
-sub off { undef $::TODO }
-
+plan 29;
fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
my $x = 7; my $a = 4; my $b = 5;
"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
is $re, '(?^i:)', '/text$qr/ inherits pragmata';
-off;
{
use re 'eval';
package bar;
}
is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
-on;
-
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
- eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b"
+my $a=4; my $b=5; eval { "a" =~ /(?{die})a/ }; print $a,$b;
CODE
-SKIP: {
- # The remaining TODO tests crash, which will display an error dialog
- # on Windows that has to be manually dismissed. We don't want this
- # to happen for release builds: 5.14.x, 5.16.x etc.
- # On UNIX, they produce ugly 'Aborted' shell output mixed in with the
- # test harness output, so skip on all platforms.
- skip "Don't run crashing TODO test on release build", 3
- if $::TODO && (int($]*1000) & 1) == 0;
+fresh_perl_is <<'CODE', 'Y45', { stderr => 1 }, '(?{eval{die}})';
+my $a=4; my $b=5;
+"a" =~ /(?{eval { die; print "X" }; print "Y"; })a/; print $a,$b;
+CODE
- fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})';
- { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+fresh_perl_is <<'CODE',
+ my $a=4; my $b=5;
+ sub f { "a" =~ /(?{print((caller(0))[3], "\n");})a/ };
+ f();
+ print $a,$b;
CODE
- fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})';
- { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
+ "main::f\n45",
+ { stderr => 1 }, 'sub f {(?{caller})}';
+
+
+fresh_perl_is <<'CODE',
+ my $a=4; my $b=5;
+ sub f { print ((caller(0))[3], "-", (caller(1))[3], "\n") };
+ "a" =~ /(?{f()})a/;
+ print $a,$b;
CODE
- fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})';
- print sub { my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->();
+ "main::f-(unknown)\n45",
+ { stderr => 1 }, 'sub f {caller} /(?{f()})/';
+
+
+fresh_perl_is <<'CODE',
+ my $a=4; my $b=5;
+ sub f {
+ "a" =~ /(?{print "X"; return; print "Y"; })a/;
+ print "Z";
+ };
+ f();
+ print $a,$b;
CODE
-}
+ "XZ45",
+ { stderr => 1 }, 'sub f {(?{return})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{last})a/; print $a,$b
+CODE
+ q{Can't "last" outside a loop block at - line 1.},
+ { stderr => 1 }, '(?{last})';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{for (1..4) {last}})a/; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, '(?{for {last}})';
+
-fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})';
- my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b
+fresh_perl_is <<'CODE',
+for (1) { my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
CODE
+ q{Can't "last" outside a loop block at - line 1.},
+ { stderr => 1 }, 'for (1) {(?{last})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; eval { "a" =~ /(?{last})a/ }; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, 'eval {(?{last})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{next})a/; print $a,$b
+CODE
+ q{Can't "next" outside a loop block at - line 1.},
+ { stderr => 1 }, '(?{next})';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; "a" =~ /(?{for (1,2,3) { next} })a/; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, '(?{for {next}})';
+
+
+fresh_perl_is <<'CODE',
+for (1) { my $a=4; my $b=5; "a" =~ /(?{next})a/ }; print $a,$b
+CODE
+ q{Can't "next" outside a loop block at - line 1.},
+ { stderr => 1 }, 'for (1) {(?{next})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5; eval { "a" =~ /(?{next})a/ }; print $a,$b
+CODE
+ '45',
+ { stderr => 1 }, 'eval {(?{next})}';
+
+
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5;
+"a" =~ /(?{ goto FOO; print "X"; })a/;
+print "Y";
+FOO:
+print $a,$b
+CODE
+ q{Can't "goto" out of a pseudo block at - line 2.},
+ { stderr => 1 }, '{(?{goto})}';
+
+
+{
+ local $::TODO = "goto doesn't yet work in pseduo blocks";
+fresh_perl_is <<'CODE',
+my $a=4; my $b=5;
+"a" =~ /(?{ goto FOO; print "X"; FOO: print "Y"; })a/;
+print "Z";
+FOO;
+print $a,$b
+CODE
+ "YZ45",
+ { stderr => 1 }, '{(?{goto FOO; FOO:})}';
+}
-off;
# [perl #92256]
{ my $y = "a"; $y =~ /a(?{ undef *_ })/ }
pass "undef *_ in a re-eval does not cause a double free";
+
+# make sure regexp warnings are reported on the right line
+# (we don't care what warning; the 32768 limit is just one
+# that was easy to reproduce) */
+{
+ use warnings;
+ my $w;
+ local $SIG{__WARN__} = sub { $w = "@_" };
+ my $qr = qr/(??{'a'})/;
+ my $filler = 1;
+ ("a" x 40_000) =~ /^$qr(ab*)+/; my $line = __LINE__;
+ like($w, qr/recursion limit.* line $line\b/, "warning on right line");
+}