summaryrefslogtreecommitdiff
path: root/pp_ctl.c
diff options
context:
space:
mode:
Diffstat (limited to 'pp_ctl.c')
-rw-r--r--pp_ctl.c138
1 files changed, 109 insertions, 29 deletions
diff --git a/pp_ctl.c b/pp_ctl.c
index 1ba4c8f83e..8691cfa053 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -26,7 +26,6 @@
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
static OP *docatch _((OP *o));
-static OP *doeval _((int gimme));
static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
static void doparseform _((SV *sv));
static I32 dopoptoeval _((I32 startingblock));
@@ -37,6 +36,7 @@ static void save_lines _((AV *array, SV *sv));
static int sortcv _((const void *, const void *));
static int sortcmp _((const void *, const void *));
static int sortcmp_locale _((const void *, const void *));
+static OP *doeval _((int gimme, OP** startop));
static I32 sortcxix;
@@ -71,21 +71,34 @@ PP(pp_regcomp) {
register char *t;
SV *tmpstr;
STRLEN len;
+ MAGIC *mg = Null(MAGIC*);
tmpstr = POPs;
- t = SvPV(tmpstr, len);
-
- /* JMR: Check against the last compiled regexp */
- if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp
- || strnNE(pm->op_pmregexp->precomp, t, len)
- || pm->op_pmregexp->precomp[len]) {
- if (pm->op_pmregexp) {
- pregfree(pm->op_pmregexp);
- pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
- }
+ if(SvROK(tmpstr)) {
+ SV *sv = SvRV(tmpstr);
+ if(SvMAGICAL(sv))
+ mg = mg_find(sv, 'r');
+ }
+ if(mg) {
+ regexp *re = (regexp *)mg->mg_obj;
+ ReREFCNT_dec(pm->op_pmregexp);
+ pm->op_pmregexp = ReREFCNT_inc(re);
+ }
+ else {
+ t = SvPV(tmpstr, len);
+
+ /* JMR: Check against the last compiled regexp */
+ if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp
+ || strnNE(pm->op_pmregexp->precomp, t, len)
+ || pm->op_pmregexp->precomp[len]) {
+ if (pm->op_pmregexp) {
+ ReREFCNT_dec(pm->op_pmregexp);
+ pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ }
- pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
- pm->op_pmregexp = pregcomp(t, t + len, pm);
+ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
+ pm->op_pmregexp = pregcomp(t, t + len, pm);
+ }
}
if (!pm->op_pmregexp->prelen && curpm)
@@ -95,7 +108,6 @@ PP(pp_regcomp) {
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
- hoistmust(pm);
cLOGOP->op_first->op_next = op->op_next;
}
RETURN;
@@ -123,13 +135,14 @@ PP(pp_substcont)
sv_catsv(dstr, POPs);
/* Are we done */
- if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig,
- s == m, Nullsv, cx->sb_safebase))
+ if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
+ s == m, Nullsv, NULL,
+ cx->sb_safebase ? 0 : REXEC_COPY_STR))
{
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
- TAINT_IF(cx->sb_rxtainted || rx->exec_tainted);
+ TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
(void)SvOOK_off(targ);
Safefree(SvPVX(targ));
@@ -158,7 +171,7 @@ PP(pp_substcont)
cx->sb_m = m = rx->startp[0];
sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0];
- cx->sb_rxtainted |= rx->exec_tainted;
+ cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
}
@@ -2087,9 +2100,63 @@ docatch(OP *o)
return Nullop;
}
+OP *
+sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
+/* sv Text to convert to OP tree. */
+/* startop op_free() this to undo. */
+/* code Short string id of the caller. */
+{
+ dSP; /* Make POPBLOCK work. */
+ PERL_CONTEXT *cx;
+ SV **newsp;
+ I32 gimme;
+ I32 optype;
+ OP dummy;
+ OP *oop = op, *rop;
+ char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
+ char *safestr;
+
+ ENTER;
+ lex_start(sv);
+ SAVETMPS;
+ /* switch to eval mode */
+
+ SAVESPTR(compiling.cop_filegv);
+ SAVEI16(compiling.cop_line);
+ sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
+ compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
+ compiling.cop_line = 1;
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (i.e. before run-time proper). To work around the coredump that
+ ensues, we always turn GvMULTI_on for any globals that were
+ introduced within evals. See force_ident(). GSAR 96-10-12 */
+ safestr = savepv(tmpbuf);
+ SAVEDELETE(defstash, safestr, strlen(safestr));
+ SAVEI32(hints);
+ SAVEPPTR(op);
+ hints = 0;
+
+ op = &dummy;
+ op->op_type = 0; /* Avoid uninit warning. */
+ op->op_flags = 0; /* Avoid uninit warning. */
+ PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHEVAL(cx, 0, compiling.cop_filegv);
+ rop = doeval(G_SCALAR, startop);
+ POPBLOCK(cx,curpm);
+ POPEVAL(cx);
+
+ (*startop)->op_type = OP_NULL;
+ (*startop)->op_ppaddr = ppaddr[OP_NULL];
+ lex_end();
+ *avp = (AV*)SvREFCNT_inc(comppad);
+ LEAVE;
+ return rop;
+}
+
/* With USE_THREADS, eval_owner must be held on entry to doeval */
static OP *
-doeval(int gimme)
+doeval(int gimme, OP** startop)
{
dSP;
OP *saveop = op;
@@ -2141,7 +2208,7 @@ doeval(int gimme)
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
- if (saveop->op_type != OP_REQUIRE)
+ if (!saveop || saveop->op_type != OP_REQUIRE)
CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
SAVEFREESV(compcv);
@@ -2165,7 +2232,7 @@ doeval(int gimme)
curcop->cop_arybase = 0;
SvREFCNT_dec(rs);
rs = newSVpv("\n", 1);
- if (saveop->op_flags & OPf_SPECIAL)
+ if (saveop && saveop->op_flags & OPf_SPECIAL)
in_eval |= 4;
else
sv_setpv(ERRSV,"");
@@ -2173,7 +2240,7 @@ doeval(int gimme)
SV **newsp;
I32 gimme;
PERL_CONTEXT *cx;
- I32 optype;
+ I32 optype = 0; /* Might be reset by POPEVAL. */
op = saveop;
if (eval_root) {
@@ -2181,14 +2248,22 @@ doeval(int gimme)
eval_root = Nullop;
}
SP = stack_base + POPMARK; /* pop original mark */
- POPBLOCK(cx,curpm);
- POPEVAL(cx);
- pop_return();
+ if (!startop) {
+ POPBLOCK(cx,curpm);
+ POPEVAL(cx);
+ pop_return();
+ }
lex_end();
LEAVE;
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, na);
DIE("%s", *msg ? msg : "Compilation failed in require");
+ } else if (startop) {
+ char* msg = SvPVx(ERRSV, na);
+
+ POPBLOCK(cx,curpm);
+ POPEVAL(cx);
+ croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
}
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
@@ -2203,7 +2278,12 @@ doeval(int gimme)
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
compiling.cop_line = 0;
- SAVEFREEOP(eval_root);
+ if (startop) {
+ *startop = eval_root;
+ SvREFCNT_dec(CvOUTSIDE(compcv));
+ CvOUTSIDE(compcv) = Nullcv;
+ } else
+ SAVEFREEOP(eval_root);
if (gimme & G_VOID)
scalarvoid(eval_root);
else if (gimme & G_ARRAY)
@@ -2229,7 +2309,7 @@ doeval(int gimme)
CvDEPTH(compcv) = 1;
SP = stack_base + POPMARK; /* pop original mark */
- op = saveop; /* The caller may need it. */
+ op = saveop; /* The caller may need it. */
#ifdef USE_THREADS
MUTEX_LOCK(&eval_mutex);
eval_owner = 0;
@@ -2382,7 +2462,7 @@ PP(pp_require)
eval_owner = thr;
MUTEX_UNLOCK(&eval_mutex);
#endif /* USE_THREADS */
- return DOCATCH(doeval(G_SCALAR));
+ return DOCATCH(doeval(G_SCALAR, NULL));
}
PP(pp_dofile)
@@ -2442,7 +2522,7 @@ PP(pp_entereval)
eval_owner = thr;
MUTEX_UNLOCK(&eval_mutex);
#endif /* USE_THREADS */
- ret = doeval(gimme);
+ ret = doeval(gimme, NULL);
if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
&& ret != op->op_next) { /* Successive compilation. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
View Lorry Controller Status