/* pp_ctl.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * Now far ahead the Road has gone,
- * And I must follow, if I can,
- * Pursuing it with eager feet,
- * Until it joins some larger way
- * Where many paths and errands meet.
- * And whither then? I cannot say.
+ * Now far ahead the Road has gone,
+ * And I must follow, if I can,
+ * Pursuing it with eager feet,
+ * Until it joins some larger way
+ * Where many paths and errands meet.
+ * And whither then? I cannot say.
+ *
+ * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
*/
/* This file contains control-oriented pp ("push/pop") functions that
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
+
PP(pp_wantarray)
{
+ dVAR;
dSP;
I32 cxix;
EXTEND(SP, 1);
PP(pp_regcreset)
{
+ dVAR;
/* XXXX Should store the old value to allow for tie/overload - and
restore in regcomp, where marked with XXXX. */
PL_reginterp_cnt = 0;
PP(pp_regcomp)
{
+ dVAR;
dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
SV *tmpstr;
- MAGIC *mg = Null(MAGIC*);
+ REGEXP *re = NULL;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
/* multiple args; concatentate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
- sv_setpvn(tmpstr, "", 0);
+ sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
if (PL_amagic_generation) {
SV *sv;
tmpstr = POPs;
if (SvROK(tmpstr)) {
- SV *sv = SvRV(tmpstr);
- if(SvMAGICAL(sv))
- mg = mg_find(sv, PERL_MAGIC_qr);
+ SV * const sv = SvRV(tmpstr);
+ if (SvTYPE(sv) == SVt_REGEXP)
+ re = (REGEXP*) sv;
}
- if (mg) {
- regexp * const re = (regexp *)mg->mg_obj;
+ if (re) {
+ re = reg_temp_copy(re);
ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, ReREFCNT_inc(re));
+ PM_SETRE(pm, re);
}
else {
STRLEN len;
- const char *t = SvPV_const(tmpstr, len);
+ const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
+ re = PM_GETRE(pm);
+ assert (re != (REGEXP*) &PL_sv_undef);
/* Check against the last compiled regexp. */
- if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
- PM_GETRE(pm)->prelen != (I32)len ||
- memNE(PM_GETRE(pm)->precomp, t, len))
+ if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
+ memNE(RX_PRECOMP(re), t, len))
{
- if (PM_GETRE(pm)) {
- ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
+ const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
+ U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+ if (re) {
+ ReREFCNT_dec(re);
+#ifdef USE_ITHREADS
+ PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
+#else
+ PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
+#endif
+ } else if (PL_curcop->cop_hints_hash) {
+ SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
+ "regcomp", 7, 0, 0);
+ if (ptr && SvIOK(ptr) && SvIV(ptr))
+ eng = INT2PTR(regexp_engine*,SvIV(ptr));
}
+
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
- pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
- if (DO_UTF8(tmpstr))
- pm->op_pmdynflags |= PMdf_DYN_UTF8;
- else {
- pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
- if (pm->op_pmdynflags & PMdf_UTF8)
- t = (char*)bytes_to_utf8((U8*)t, &len);
+ if (DO_UTF8(tmpstr)) {
+ assert (SvUTF8(tmpstr));
+ } else if (SvUTF8(tmpstr)) {
+ /* Not doing UTF-8, despite what the SV says. Is this only if
+ we're trapped in use 'bytes'? */
+ /* Make a copy of the octet sequence, but without the flag on,
+ as the compiler now honours the SvUTF8 flag on tmpstr. */
+ STRLEN len;
+ const char *const p = SvPV(tmpstr, len);
+ tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
}
- PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
- if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
- Safefree(t);
+
+ if (eng)
+ PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
+ else
+ PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
+
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
inside tie/overload accessors. */
}
}
+
+ re = PM_GETRE(pm);
#ifndef INCOMPLETE_TAINTS
if (PL_tainting) {
if (PL_tainted)
- pm->op_pmdynflags |= PMdf_TAINTED;
+ RX_EXTFLAGS(re) |= RXf_TAINTED;
else
- pm->op_pmdynflags &= ~PMdf_TAINTED;
+ RX_EXTFLAGS(re) &= ~RXf_TAINTED;
}
#endif
- if (!PM_GETRE(pm)->prelen && PL_curpm)
+ if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
pm = PL_curpm;
- else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
- pm->op_pmflags |= PMf_WHITE;
- else
- pm->op_pmflags &= ~PMf_WHITE;
- /* XXX runtime compiled output needs to move to the pad */
+
+#if !defined(USE_ITHREADS)
+ /* can't change the optree at runtime either */
+ /* PMf_KEEP is handled differently under threads to avoid these problems */
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
-#if !defined(USE_ITHREADS)
- /* XXX can't change the optree at runtime either */
cLOGOP->op_first->op_next = PL_op->op_next;
-#endif
}
+#endif
RETURN;
}
PP(pp_substcont)
{
+ dVAR;
dSP;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
register PMOP * const pm = (PMOP*) cLOGOP->op_other;
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP * const rx = cx->sb_rx;
- SV *nsv = Nullsv;
+ SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
if(old != rx) {
if(old)
ReREFCNT_dec(old);
- PM_SETRE(pm,rx);
+ PM_SETRE(pm,ReREFCNT_inc(rx));
}
rxres_restore(&cx->sb_rxres, rx);
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
sv_catsv(dstr, POPs);
- FREETMPS; /* Prevent excess tmp stack */
/* Are we done */
- if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
+ if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
s == m, cx->sb_targ, NULL,
((cx->sb_rflags & REXEC_COPY_STR)
? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
SvLEN_set(targ, SvLEN(dstr));
if (DO_UTF8(dstr))
SvUTF8_on(targ);
- SvPV_set(dstr, (char*)0);
- sv_free(dstr);
+ SvPV_set(dstr, NULL);
TAINT_IF(cx->sb_rxtainted & 1);
- PUSHs(sv_2mortal(newSViv(saviters - 1)));
+ mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
- ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
cx->sb_iters = saviters;
}
- if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
+ if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
- cx->sb_orig = orig = rx->subbeg;
+ cx->sb_orig = orig = RX_SUBBEG(rx);
s = orig + (m - s);
cx->sb_strend = s + (cx->sb_strend - m);
}
- cx->sb_m = m = rx->startp[0] + orig;
+ cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
if (m > s) {
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
else
sv_catpvn(dstr, s, m-s);
}
- cx->sb_s = rx->endp[0] + orig;
+ cx->sb_s = RX_OFFS(rx)[0].end + orig;
{ /* Update the pos() information. */
SV * const sv = cx->sb_targ;
MAGIC *mg;
- I32 i;
- if (SvTYPE(sv) < SVt_PVMG)
- SvUPGRADE(sv, SVt_PVMG);
+ SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
- sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
- mg = mg_find(sv, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(sv))
+ sv_force_normal_flags(sv, 0);
+#endif
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
+ NULL, 0);
}
- i = m - orig;
- if (DO_UTF8(sv))
- sv_pos_b2u(sv, &i);
- mg->mg_len = i;
+ mg->mg_len = m - orig;
}
if (old != rx)
(void)ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
- RETURNOP(pm->op_pmreplstart);
+ RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
}
void
UV *p = (UV*)*rsp;
U32 i;
- if (!p || p[1] < rx->nparens) {
+ PERL_ARGS_ASSERT_RXRES_SAVE;
+ PERL_UNUSED_CONTEXT;
+
+ if (!p || p[1] < RX_NPARENS(rx)) {
#ifdef PERL_OLD_COPY_ON_WRITE
- i = 7 + rx->nparens * 2;
+ i = 7 + RX_NPARENS(rx) * 2;
#else
- i = 6 + rx->nparens * 2;
+ i = 6 + RX_NPARENS(rx) * 2;
#endif
if (!p)
Newx(p, i, UV);
*rsp = (void*)p;
}
- *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
+ *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
RX_MATCH_COPIED_off(rx);
#ifdef PERL_OLD_COPY_ON_WRITE
- *p++ = PTR2UV(rx->saved_copy);
- rx->saved_copy = Nullsv;
+ *p++ = PTR2UV(RX_SAVED_COPY(rx));
+ RX_SAVED_COPY(rx) = NULL;
#endif
- *p++ = rx->nparens;
+ *p++ = RX_NPARENS(rx);
- *p++ = PTR2UV(rx->subbeg);
- *p++ = (UV)rx->sublen;
- for (i = 0; i <= rx->nparens; ++i) {
- *p++ = (UV)rx->startp[i];
- *p++ = (UV)rx->endp[i];
+ *p++ = PTR2UV(RX_SUBBEG(rx));
+ *p++ = (UV)RX_SUBLEN(rx);
+ for (i = 0; i <= RX_NPARENS(rx); ++i) {
+ *p++ = (UV)RX_OFFS(rx)[i].start;
+ *p++ = (UV)RX_OFFS(rx)[i].end;
}
}
-void
-Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
+static void
+S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
{
UV *p = (UV*)*rsp;
U32 i;
+ PERL_ARGS_ASSERT_RXRES_RESTORE;
+ PERL_UNUSED_CONTEXT;
+
RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
#ifdef PERL_OLD_COPY_ON_WRITE
- if (rx->saved_copy)
- SvREFCNT_dec (rx->saved_copy);
- rx->saved_copy = INT2PTR(SV*,*p);
+ if (RX_SAVED_COPY(rx))
+ SvREFCNT_dec (RX_SAVED_COPY(rx));
+ RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
*p++ = 0;
#endif
- rx->nparens = *p++;
+ RX_NPARENS(rx) = *p++;
- rx->subbeg = INT2PTR(char*,*p++);
- rx->sublen = (I32)(*p++);
- for (i = 0; i <= rx->nparens; ++i) {
- rx->startp[i] = (I32)(*p++);
- rx->endp[i] = (I32)(*p++);
+ RX_SUBBEG(rx) = INT2PTR(char*,*p++);
+ RX_SUBLEN(rx) = (I32)(*p++);
+ for (i = 0; i <= RX_NPARENS(rx); ++i) {
+ RX_OFFS(rx)[i].start = (I32)(*p++);
+ RX_OFFS(rx)[i].end = (I32)(*p++);
}
}
-void
-Perl_rxres_free(pTHX_ void **rsp)
+static void
+S_rxres_free(pTHX_ void **rsp)
{
UV * const p = (UV*)*rsp;
+ PERL_ARGS_ASSERT_RXRES_FREE;
+ PERL_UNUSED_CONTEXT;
+
if (p) {
#ifdef PERL_POISON
void *tmp = INT2PTR(char*,*p);
Safefree(tmp);
if (*p)
- Poison(*p, 1, sizeof(*p));
+ PoisonFree(*p, 1, sizeof(*p));
#else
Safefree(INT2PTR(char*,*p));
#endif
}
#endif
Safefree(p);
- *rsp = Null(void*);
+ *rsp = NULL;
}
}
PP(pp_formline)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
register SV * const tmpForm = *++MARK;
register U32 *fpc;
register char *t;
const char *f;
register I32 arg;
- register SV *sv = Nullsv;
- const char *item = Nullch;
+ register SV *sv = NULL;
+ const char *item = NULL;
I32 itemsize = 0;
I32 fieldsize = 0;
I32 lines = 0;
- bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
- const char *chophere = Nullch;
- char *linemark = Nullch;
+ bool chopspace = (strchr(PL_chopset, ' ') != NULL);
+ const char *chophere = NULL;
+ char *linemark = NULL;
NV value;
bool gotsome = FALSE;
STRLEN len;
? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
- SV * nsv = Nullsv;
- OP * parseres = 0;
+ SV * nsv = NULL;
+ OP * parseres = NULL;
const char *fmt;
- bool oneline;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
if (SvREADONLY(tmpForm)) {
*t = '\0';
sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
t = SvEND(PL_formtarget);
+ f += arg;
break;
}
if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_utf8_upgrade(PL_formtarget);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
}
if (!targ_is_utf8) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_utf8_upgrade(PL_formtarget);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
+ fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
}
case FF_LINESNGL:
chopspace = 0;
- oneline = TRUE;
- goto ff_line;
case FF_LINEGLOB:
- oneline = FALSE;
- ff_line:
{
+ const bool oneline = fpc[-1] == FF_LINESNGL;
const char *s = item = SvPV_const(sv, len);
+ item_is_utf8 = DO_UTF8(sv);
itemsize = len;
- if ((item_is_utf8 = DO_UTF8(sv)))
- itemsize = sv_len_utf8(sv);
if (itemsize) {
- bool chopped = FALSE;
+ STRLEN to_copy = itemsize;
const char *const send = s + len;
+ const U8 *source = (const U8 *) s;
+ U8 *tmp = NULL;
+
gotsome = TRUE;
chophere = s + itemsize;
while (s < send) {
if (*s++ == '\n') {
if (oneline) {
- chopped = TRUE;
+ to_copy = s - SvPVX_const(sv) - 1;
chophere = s;
break;
} else {
if (s == send) {
itemsize--;
- chopped = TRUE;
+ to_copy--;
} else
lines++;
}
}
}
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- if (targ_is_utf8)
- SvUTF8_on(PL_formtarget);
- if (oneline) {
- SvCUR_set(sv, chophere - item);
- sv_catsv(PL_formtarget, sv);
- SvCUR_set(sv, itemsize);
- } else
- sv_catsv(PL_formtarget, sv);
- if (chopped)
- SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ if (targ_is_utf8 && !item_is_utf8) {
+ source = tmp = bytes_to_utf8(source, &to_copy);
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ } else {
+ if (item_is_utf8 && !targ_is_utf8) {
+ /* Upgrade targ to UTF8, and then we reduce it to
+ a problem we have a simple solution for. */
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ targ_is_utf8 = TRUE;
+ /* Don't need get magic. */
+ sv_utf8_upgrade_nomg(PL_formtarget);
+ } else {
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ }
+
+ /* Easy. They agree. */
+ assert (item_is_utf8 == targ_is_utf8);
+ }
+ SvGROW(PL_formtarget,
+ SvCUR(PL_formtarget) + to_copy + fudge + 1);
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
- if (item_is_utf8)
- targ_is_utf8 = TRUE;
+
+ Copy(source, t, to_copy, char);
+ t += to_copy;
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
+ if (item_is_utf8) {
+ if (SvGMAGICAL(sv)) {
+ /* Mustn't call sv_pos_b2u() as it does a second
+ mg_get(). Is this a bug? Do we need a _flags()
+ variant? */
+ itemsize = utf8_length(source, source + itemsize);
+ } else {
+ sv_pos_b2u(sv, &itemsize);
+ }
+ assert(!tmp);
+ } else if (tmp) {
+ Safefree(tmp);
+ }
}
break;
}
case FF_0DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
- fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
+ fmt = (const char *)
+ ((arg & 256) ?
+ "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
#else
- fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
+ fmt = (const char *)
+ ((arg & 256) ?
+ "%#0*.*f" : "%0*.*f");
#endif
goto ff_dec;
case FF_DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
- fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
+ fmt = (const char *)
+ ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
#else
- fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
+ fmt = (const char *)
+ ((arg & 256) ? "%#*.*f" : "%*.*f");
#endif
ff_dec:
/* If the field is marked with ^ and the value is undefined,
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
- sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
+ my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
if (PL_stack_base + *PL_markstack_ptr == SP) {
(void)POPMARK;
if (GIMME_V == G_SCALAR)
- XPUSHs(sv_2mortal(newSViv(0)));
+ mXPUSHi(0);
RETURNOP(PL_op->op_next->op_next);
}
PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
- DEFSV = src;
+ DEFSV_set(src);
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
- DEFSV = src;
+ DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
PP(pp_range)
{
+ dVAR;
if (GIMME == G_ARRAY)
return NORMAL;
if (SvTRUEx(PAD_SV(PL_op->op_targ)))
PP(pp_flip)
{
+ dVAR;
dSP;
if (GIMME == G_ARRAY) {
flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
}
else {
- GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
+ GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
if (gv && GvSV(gv))
flip = SvIV(sv) == SvIV(GvSV(gv));
}
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpvn(TARG, "", 0);
+ sv_setpvs(TARG, "");
SETs(targ);
RETURN;
}
PP(pp_flop)
{
- dSP;
+ dVAR; dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
}
else {
- GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
+ GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
}
}
if (flop) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
- sv_catpvn(targ, "E0", 2);
+ sv_catpvs(targ, "E0");
}
SETs(targ);
}
static const char * const context_name[] = {
"pseudo-block",
+ NULL, /* CXt_WHEN never actually needs "block" */
+ NULL, /* CXt_BLOCK never actually needs "block" */
+ NULL, /* CXt_GIVEN never actually needs "block" */
+ NULL, /* CXt_LOOP_FOR never actually needs "loop" */
+ NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
+ NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
+ NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
"subroutine",
+ "format",
"eval",
- "loop",
"substitution",
- "block",
- "format"
};
STATIC I32
S_dopoptolabel(pTHX_ const char *label)
{
+ dVAR;
register I32 i;
+ PERL_ARGS_ASSERT_DOPOPTOLABEL;
+
for (i = cxstack_ix; i >= 0; i--) {
register const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
if (CxTYPE(cx) == CXt_NULL)
return -1;
break;
- case CXt_LOOP:
- if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
+ if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
- (long)i, cx->blk_loop.label));
+ (long)i, CxLABEL(cx)));
continue;
}
DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
return i;
}
+
+
I32
Perl_dowantarray(pTHX)
{
+ dVAR;
const I32 gimme = block_gimme();
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
I32
Perl_block_gimme(pTHX)
{
+ dVAR;
const I32 cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
return G_VOID;
I32
Perl_is_lvalue_sub(pTHX)
{
+ dVAR;
const I32 cxix = dopoptosub(cxstack_ix);
assert(cxix >= 0); /* We should only be called from inside subs */
- if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
- return cxstack[cxix].blk_sub.lval;
+ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return CxLVAL(cxstack + cxix);
else
return 0;
}
STATIC I32
-S_dopoptosub(pTHX_ I32 startingblock)
-{
- return dopoptosub_at(cxstack, startingblock);
-}
-
-STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
+ dVAR;
I32 i;
+
+ PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
+
for (i = startingblock; i >= 0; i--) {
register const PERL_CONTEXT * const cx = &cxstk[i];
switch (CxTYPE(cx)) {
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
+ dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
register const PERL_CONTEXT *cx = &cxstack[i];
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
+ dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
register const PERL_CONTEXT * const cx = &cxstack[i];
if ((CxTYPE(cx)) == CXt_NULL)
return -1;
break;
- case CXt_LOOP:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
return i;
}
return i;
}
+STATIC I32
+S_dopoptogiven(pTHX_ I32 startingblock)
+{
+ dVAR;
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_GIVEN:
+ DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ return i;
+ case CXt_LOOP_PLAIN:
+ assert(!CxFOREACHDEF(cx));
+ break;
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ if (CxFOREACHDEF(cx)) {
+ DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ }
+ return i;
+}
+
+STATIC I32
+S_dopoptowhen(pTHX_ I32 startingblock)
+{
+ dVAR;
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_WHEN:
+ DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
void
Perl_dounwind(pTHX_ I32 cxix)
{
+ dVAR;
I32 optype;
while (cxstack_ix > cxix) {
case CXt_EVAL:
POPEVAL(cx);
break;
- case CXt_LOOP:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
POPLOOP(cx);
break;
case CXt_NULL:
void
Perl_qerror(pTHX_ SV *err)
{
+ dVAR;
+
+ PERL_ARGS_ASSERT_QERROR;
+
if (PL_in_eval)
sv_catsv(ERRSV, err);
else if (PL_errors)
sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%"SVf, err);
- ++PL_error_count;
+ Perl_warn(aTHX_ "%"SVf, SVfARG(err));
+ if (PL_parser)
+ ++PL_parser->error_count;
}
OP *
if (PL_in_eval & EVAL_KEEPERR) {
static const char prefix[] = "\t(in cleanup) ";
SV * const err = ERRSV;
- const char *e = Nullch;
+ const char *e = NULL;
if (!SvPOK(err))
- sv_setpvn(err,"",0);
+ sv_setpvs(err,"");
else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
STRLEN len;
e = SvPV_const(err, len);
e += len - msglen;
if (*e != *message || strNE(e,message))
- e = Nullch;
+ e = NULL;
}
if (!e) {
SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
sv_catpvn(err, message, msglen);
if (ckWARN(WARN_MISC)) {
const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
+ SvPVX_const(err)+start);
}
}
}
if (CxTYPE(cx) != CXt_EVAL) {
if (!message)
message = SvPVx_const(ERRSV, msglen);
- PerlIO_write(Perl_error_log, "panic: die ", 11);
+ PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
}
PP(pp_xor)
{
- dSP; dPOPTOPssrl;
+ dVAR; dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
PP(pp_caller)
{
+ dVAR;
dSP;
register I32 cxix = dopoptosub(cxstack_ix);
register const PERL_CONTEXT *cx;
RETURN;
}
- EXTEND(SP, 10);
+ EXTEND(SP, 11);
if (!stashname)
PUSHs(&PL_sv_undef);
else
- PUSHs(sv_2mortal(newSVpv(stashname, 0)));
- PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
- PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
+ mPUSHs(newSVpv(stashname, 0));
+ mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
+ mPUSHi((I32)CopLINE(cx->blk_oldcop));
if (!MAXARG)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
/* So is ccstack[dbcxix]. */
if (isGV(cvgv)) {
- SV * const sv = NEWSV(49, 0);
- gv_efullname3(sv, cvgv, Nullch);
- PUSHs(sv_2mortal(sv));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+ SV * const sv = newSV(0);
+ gv_efullname3(sv, cvgv, NULL);
+ mPUSHs(sv);
+ PUSHs(boolSV(CxHASARGS(cx)));
}
else {
- PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+ PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
+ PUSHs(boolSV(CxHASARGS(cx)));
}
}
else {
- PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
- PUSHs(sv_2mortal(newSViv(0)));
+ PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
+ mPUSHi(0);
}
gimme = (I32)cx->blk_gimme;
if (gimme == G_VOID)
PUSHs(&PL_sv_undef);
else
- PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
+ PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
if (CxTYPE(cx) == CXt_EVAL) {
/* eval STRING */
- if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
+ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
PUSHs(cx->blk_eval.cur_text);
PUSHs(&PL_sv_no);
}
/* require */
else if (cx->blk_eval.old_namesv) {
- PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
+ mPUSHs(newSVsv(cx->blk_eval.old_namesv));
PUSHs(&PL_sv_yes);
}
/* eval BLOCK (try blocks have old_namesv == 0) */
PUSHs(&PL_sv_undef);
PUSHs(&PL_sv_undef);
}
- if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
&& CopSTASH_eq(PL_curcop, PL_debstash))
{
AV * const ary = cx->blk_sub.argarray;
const int off = AvARRAY(ary) - AvALLOC(ary);
if (!PL_dbargs) {
- GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
- PL_dbargs = GvAV(gv_AVadd(tmpgv));
- GvMULTI_on(tmpgv);
+ PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
+ SVt_PVAV)));
AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
}
/* XXX only hints propagated via op_private are currently
* visible (others are not easily accessible, since they
* use the global PL_hints) */
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
- HINT_PRIVATE_MASK)));
+ mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
- SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
+ STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
if (old_warnings == pWARN_NONE ||
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
/* Get the bit mask for $warnings::Bits{all}, because
* it could have been extended by warnings::register */
SV **bits_all;
- HV * const bits = get_hv("warnings::Bits", FALSE);
- if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
+ HV * const bits = get_hv("warnings::Bits", 0);
+ if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
mask = newSVsv(*bits_all);
}
else {
}
}
else
- mask = newSVsv(old_warnings);
- PUSHs(sv_2mortal(mask));
+ mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
+ mPUSHs(mask);
}
+
+ PUSHs(cx->blk_oldcop->cop_hints_hash ?
+ sv_2mortal(newRV_noinc(
+ MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
+ cx->blk_oldcop->cop_hints_hash))))
+ : &PL_sv_undef);
RETURN;
}
PP(pp_reset)
{
+ dVAR;
dSP;
- const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
+ const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
sv_reset(tmps, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
hasargs = 0;
SPAGAIN;
- if (CvXSUB(cv)) {
+ if (CvISXSUB(cv)) {
CvDEPTH(cv)++;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
SV **svp;
- U32 cxtype = CXt_LOOP;
+ U8 cxtype = CXt_LOOP_FOR;
#ifdef USE_ITHREADS
- void *iterdata;
+ PAD *iterdata;
#endif
ENTER;
SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
SVs_PADSTALE, SVs_PADSTALE);
}
+ SAVEPADSVANDMORTALIZE(PL_op->op_targ);
#ifndef USE_ITHREADS
svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
- SAVESPTR(*svp);
#else
- SAVEPADSV(PL_op->op_targ);
- iterdata = INT2PTR(void*, PL_op->op_targ);
- cxtype |= CXp_PADVAR;
+ iterdata = NULL;
#endif
}
else {
- GV * const gv = (GV*)POPs;
+ GV * const gv = MUTABLE_GV(POPs);
svp = &GvSV(gv); /* symbol table variable */
SAVEGENERICSV(*svp);
- *svp = NEWSV(0,0);
+ *svp = newSV(0);
#ifdef USE_ITHREADS
- iterdata = (void*)gv;
+ iterdata = (PAD*)gv;
#endif
}
+ if (PL_op->op_private & OPpITER_DEF)
+ cxtype |= CXp_FOR_DEF;
+
ENTER;
PUSHBLOCK(cx, cxtype, SP);
#ifdef USE_ITHREADS
- PUSHLOOP(cx, iterdata, MARK);
+ PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
#else
- PUSHLOOP(cx, svp, MARK);
+ PUSHLOOP_FOR(cx, svp, MARK, 0);
#endif
if (PL_op->op_flags & OPf_STACKED) {
- cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
- if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
+ SV *maybe_ary = POPs;
+ if (SvTYPE(maybe_ary) != SVt_PVAV) {
dPOPss;
- SV * const right = (SV*)cx->blk_loop.iterary;
+ SV * const right = maybe_ary;
SvGETMAGIC(sv);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(sv,right)) {
- if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
- (SvOK(right) && SvNV(right) >= IV_MAX))
+ cx->cx_type &= ~CXTYPEMASK;
+ cx->cx_type |= CXt_LOOP_LAZYIV;
+ /* Make sure that no-one re-orders cop.h and breaks our
+ assumptions */
+ assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
+#ifdef NV_PRESERVES_UV
+ if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
+ (SvNV(sv) > (NV)IV_MAX)))
+ ||
+ (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
+ (SvNV(right) < (NV)IV_MIN))))
+#else
+ if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
+ ||
+ ((SvNV(sv) > 0) &&
+ ((SvUV(sv) > (UV)IV_MAX) ||
+ (SvNV(sv) > (NV)UV_MAX)))))
+ ||
+ (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
+ ||
+ ((SvNV(right) > 0) &&
+ ((SvUV(right) > (UV)IV_MAX) ||
+ (SvNV(right) > (NV)UV_MAX))))))
+#endif
DIE(aTHX_ "Range iterator outside integer range");
- cx->blk_loop.iterix = SvIV(sv);
- cx->blk_loop.itermax = SvIV(right);
+ cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
+ cx->blk_loop.state_u.lazyiv.end = SvIV(right);
#ifdef DEBUGGING
/* for correct -Dstv display */
cx->blk_oldsp = sp - PL_stack_base;
#endif
}
else {
- cx->blk_loop.iterlval = newSVsv(sv);
- (void) SvPV_force_nolen(cx->blk_loop.iterlval);
+ cx->cx_type &= ~CXTYPEMASK;
+ cx->cx_type |= CXt_LOOP_LAZYSV;
+ /* Make sure that no-one re-orders cop.h and breaks our
+ assumptions */
+ assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
+ cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
+ cx->blk_loop.state_u.lazysv.end = right;
+ SvREFCNT_inc(right);
+ (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
+ /* This will do the upgrade to SVt_PV, and warn if the value
+ is uninitialised. */
(void) SvPV_nolen_const(right);
+ /* Doing this avoids a check every time in pp_iter in pp_hot.c
+ to replace !SvOK() with a pointer to "". */
+ if (!SvOK(right)) {
+ SvREFCNT_dec(right);
+ cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
+ }
}
}
- else if (PL_op->op_private & OPpITER_REVERSED) {
- cx->blk_loop.itermax = 0;
- cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
-
+ else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
+ cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
+ SvREFCNT_inc(maybe_ary);
+ cx->blk_loop.state_u.ary.ix =
+ (PL_op->op_private & OPpITER_REVERSED) ?
+ AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
+ -1;
}
}
- else {
- cx->blk_loop.iterary = PL_curstack;
- AvFILLp(PL_curstack) = SP - PL_stack_base;
+ else { /* iterating over items on the stack */
+ cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
if (PL_op->op_private & OPpITER_REVERSED) {
- cx->blk_loop.itermax = MARK - PL_stack_base + 1;
- cx->blk_loop.iterix = cx->blk_oldsp + 1;
+ cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
}
else {
- cx->blk_loop.iterix = MARK - PL_stack_base;
+ cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
}
}
SAVETMPS;
ENTER;
- PUSHBLOCK(cx, CXt_LOOP, SP);
- PUSHLOOP(cx, 0, SP);
+ PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
+ PUSHLOOP_PLAIN(cx, SP);
RETURN;
}
SV **mark;
POPBLOCK(cx,newpm);
- assert(CxTYPE(cx) == CXt_LOOP);
+ assert(CxTYPE_is_LOOP(cx));
mark = newsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
TAINT_NOT;
if (gimme == G_VOID)
- ; /* do nothing */
+ NOOP;
else if (gimme == G_SCALAR) {
if (mark < SP)
*++newsp = sv_mortalcopy(*SP);
/* Unassume the success we assumed earlier. */
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", nsv);
+ DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
}
break;
case CXt_FORMAT:
POPSUB(cx,sv); /* release CV and @_ ... */
}
else
- sv = Nullsv;
+ sv = NULL;
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
- if (clear_errsv)
- sv_setpvn(ERRSV,"",0);
+ if (clear_errsv) {
+ CLEAR_ERRSV();
+ }
return retop;
}
SV **newsp;
PMOP *newpm;
SV **mark;
- SV *sv = Nullsv;
+ SV *sv = NULL;
if (PL_op->op_flags & OPf_SPECIAL) {
cxstack_ix++; /* temporarily protect top context */
mark = newsp;
switch (CxTYPE(cx)) {
- case CXt_LOOP:
- pop2 = CXt_LOOP;
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
+ pop2 = CxTYPE(cx);
newsp = PL_stack_base + cx->blk_loop.resetsp;
- nextop = cx->blk_loop.last_op->op_next;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
break;
case CXt_SUB:
pop2 = CXt_SUB;
cxstack_ix--;
/* Stack values are safe: */
switch (pop2) {
- case CXt_LOOP:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
POPLOOP(cx); /* release loop vars ... */
LEAVE;
break;
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
- return cx->blk_loop.next_op;
+ return CX_LOOP_NEXTOP_GET(cx);
}
PP(pp_redo)
if (cxix < cxstack_ix)
dounwind(cxix);
- redo_op = cxstack[cxix].blk_loop.redo_op;
+ redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
/* pop one less context to avoid $x being freed in while (my $x..) */
cxstack_ix++;
STATIC OP *
S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
{
+ dVAR;
OP **ops = opstack;
static const char too_deep[] = "Target of goto is too deeply nested";
+ PERL_ARGS_ASSERT_DOFINDLABEL;
+
if (ops >= oplimit)
Perl_croak(aTHX_ too_deep);
if (o->op_type == OP_LEAVE ||
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- kCOP->cop_label && strEQ(kCOP->cop_label, label))
+ CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
return kid;
}
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
PP(pp_goto)
{
dVAR; dSP;
- OP *retop = 0;
+ OP *retop = NULL;
I32 ix;
register PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
- const char *label = 0;
+ const char *label = NULL;
const bool do_dump = (PL_op->op_type == OP_DUMP);
static const char must_have_label[] = "goto must have label";
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
I32 cxix;
register PERL_CONTEXT *cx;
- CV* cv = (CV*)SvRV(sv);
+ CV *cv = MUTABLE_CV(SvRV(sv));
SV** mark;
I32 items = 0;
I32 oldsave;
if (autogv && (cv = GvCV(autogv)))
goto retry;
tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
+ gv_efullname3(tmpstr, gv, NULL);
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
}
DIE(aTHX_ "Goto undefined subroutine");
}
/* First do some returnish stuff. */
- (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
}
else if (CxMULTICALL(cx))
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
- if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
+ if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
av = newAV();
av_extend(av, items-1);
AvREIFY_only(av);
- PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
+ PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
}
}
- else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
+ else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* const av = GvAV(PL_defgv);
items = AvFILLp(av) + 1;
EXTEND(SP, items+1); /* @_ could have been extended. */
/* Now do some callish stuff. */
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
- if (CvXSUB(cv)) {
- OP* retop = cx->blk_sub.retop;
+ if (CvISXSUB(cv)) {
+ OP* const retop = cx->blk_sub.retop;
+ SV **newsp;
+ I32 gimme;
if (reified) {
I32 index;
for (index=0; index<items; index++)
sv_2mortal(SP[-index]);
}
-#ifdef PERL_XSUB_OLDSTYLE
- if (CvOLDSTYLE(cv)) {
- I32 (*fp3)(int,int,int);
- while (SP > mark) {
- SP[1] = SP[0];
- SP--;
- }
- fp3 = (I32(*)(int,int,int))CvXSUB(cv);
- items = (*fp3)(CvXSUBANY(cv).any_i32,
- mark - PL_stack_base + 1,
- items);
- SP = PL_stack_base + items;
- }
- else
-#endif /* PERL_XSUB_OLDSTYLE */
- {
- SV **newsp;
- I32 gimme;
- /* XS subs don't have a CxSUB, so pop it */
- POPBLOCK(cx, PL_curpm);
- /* Push a mark for the start of arglist */
- PUSHMARK(mark);
- PUTBACK;
- (void)(*CvXSUB(cv))(aTHX_ cv);
- /* Put these at the bottom since the vars are set but not used */
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
- }
+ /* XS subs don't have a CxSUB, so pop it */
+ POPBLOCK(cx, PL_curpm);
+ /* Push a mark for the start of arglist */
+ PUSHMARK(mark);
+ PUTBACK;
+ (void)(*CvXSUB(cv))(aTHX_ cv);
LEAVE;
return retop;
}
else {
- AV* padlist = CvPADLIST(cv);
+ AV* const padlist = CvPADLIST(cv);
if (CxTYPE(cx) == CXt_EVAL) {
- PL_in_eval = cx->blk_eval.old_in_eval;
+ PL_in_eval = CxOLD_IN_EVAL(cx);
PL_eval_root = cx->blk_eval.old_eval_root;
cx->cx_type = CXt_SUB;
- cx->blk_sub.hasargs = 0;
}
cx->blk_sub.cv = cv;
- cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
+ cx->blk_sub.olddepth = CvDEPTH(cv);
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
+ SvREFCNT_inc_simple_void_NN(cv);
else {
- if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
+ if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
pad_push(padlist, CvDEPTH(cv));
}
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (cx->blk_sub.hasargs)
+ if (CxHASARGS(cx))
{
- AV* av = (AV*)PAD_SVl(0);
- SV** ary;
+ AV *const av = MUTABLE_AV(PAD_SVl(0));
cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+ GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
if (items >= AvMAX(av) + 1) {
- ary = AvALLOC(av);
+ SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
if (items >= AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items+1,SV*);
AvALLOC(av) = ary;
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
}
++mark;
}
}
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
- /*
- * We do not care about using sv to call CV;
- * it's for informational purposes only.
- */
- SV * const sv = GvSV(PL_DBsub);
- CV *gotocv;
-
- save_item(sv);
- if (PERLDB_SUB_NN) {
- const int type = SvTYPE(sv);
- if (type < SVt_PVIV && type != SVt_IV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
- } else {
- gv_efullname3(sv, CvGV(cv), Nullch);
- }
- if ( PERLDB_GOTO
- && (gotocv = get_cv("DB::goto", FALSE)) ) {
- PUSHMARK( PL_stack_sp );
- call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
- PL_stack_sp--;
+ Perl_get_db_sub(aTHX_ NULL, cv);
+ if (PERLDB_GOTO) {
+ CV * const gotocv = get_cvs("DB::goto", 0);
+ if (gotocv) {
+ PUSHMARK( PL_stack_sp );
+ call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
+ PL_stack_sp--;
+ }
}
}
RETURNOP(CvSTART(cv));
label = cPVOP->op_pv;
if (label && *label) {
- OP *gotoprobe = 0;
+ OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
- PERL_CONTEXT *last_eval_cx = 0;
+ PERL_CONTEXT *last_eval_cx = NULL;
/* find label */
- PL_lastgotoprobe = 0;
+ PL_lastgotoprobe = NULL;
*enterops = 0;
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
break;
}
/* else fall through */
- case CXt_LOOP:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
+ case CXt_GIVEN:
+ case CXt_WHEN:
gotoprobe = cx->blk_oldcop->op_sibling;
break;
case CXt_SUBST:
PP(pp_exit)
{
+ dVAR;
dSP;
I32 anum;
#endif
}
PL_exit_flags |= PERL_EXIT_EXPECTED;
+#ifdef PERL_MAD
+ /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
+ if (anum || !(PL_minus_c && PL_madskills))
+ my_exit(anum);
+#else
my_exit(anum);
+#endif
PUSHs(&PL_sv_undef);
RETURN;
}
-#ifdef NOTYET
-PP(pp_nswitch)
-{
- dSP;
- const NV value = SvNVx(GvSV(cCOP->cop_gv));
- register I32 match = I_32(value);
-
- if (value < 0.0) {
- if (((NV)match) > value)
- --match; /* was fractional--truncate other way */
- }
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- PL_op = cCOP->uop.scop.scop_next[match];
- RETURNOP(PL_op);
-}
-
-PP(pp_cswitch)
-{
- dSP;
- register I32 match;
-
- if (PL_multiline)
- PL_op = PL_op->op_next; /* can't assume anything */
- else {
- match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- PL_op = cCOP->uop.scop.scop_next[match];
- }
- RETURNOP(PL_op);
-}
-#endif
-
/* Eval. */
STATIC void
const char * const send = SvPVX_const(sv) + SvCUR(sv);
I32 line = 1;
+ PERL_ARGS_ASSERT_SAVE_LINES;
+
while (s && s < send) {
const char *t;
- SV * const tmpstr = NEWSV(85,0);
+ SV * const tmpstr = newSV_type(SVt_PVMG);
- sv_upgrade(tmpstr, SVt_PVMG);
- t = strchr(s, '\n');
+ t = (const char *)memchr(s, '\n', send - s);
if (t)
t++;
else
}
}
-STATIC void
-S_docatch_body(pTHX)
-{
- CALLRUNOPS(aTHX);
- return;
-}
-
STATIC OP *
S_docatch(pTHX_ OP *o)
{
+ dVAR;
int ret;
OP * const oldop = PL_op;
dJMPENV;
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
redo_body:
- docatch_body();
+ CALLRUNOPS(aTHX);
break;
case 3:
/* die caught by an inner eval - continue inner loop */
}
JMPENV_POP;
PL_op = oldop;
- return Nullop;
+ return NULL;
}
OP *
I32 gimme = G_VOID;
I32 optype;
OP dummy;
- OP *rop;
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
int runtime;
- CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
+ CV* runcv = NULL; /* initialise to avoid compiler warnings */
STRLEN len;
+ PERL_ARGS_ASSERT_SV_COMPILE_2OP;
+
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
len = SvCUR(sv);
}
else
- len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
- (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
+ (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0, Nullgv);
+ PUSHEVAL(cx, 0);
if (runtime)
- rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+ (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
else
- rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
+ (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
lex_end();
/* XXX DAPM do this properly one year */
- *padp = (AV*)SvREFCNT_inc(PL_comppad);
+ *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
LEAVE;
if (IN_PERL_COMPILETIME)
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
#ifdef OP_IN_REGISTER
op = PL_opsave;
#endif
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
- return rop;
+ return PL_eval_start;
}
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
+ dVAR;
PERL_SI *si;
if (db_seqp)
* In the last case, startop is non-null, and contains the address of
* a pointer that should be set to the just-compiled code.
* outside is the lexically enclosing CV (if any) that invoked us.
+ * Returns a bool indicating whether the compile was successful; if so,
+ * PL_eval_start contains the first op of the compiled ocde; otherwise,
+ * pushes undef (also croaks if startop != NULL).
*/
-/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
-STATIC OP *
+STATIC bool
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dVAR; dSP;
PUSHMARK(SP);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)PL_compcv, SVt_PVCV);
+ PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvEVAL_on(PL_compcv);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
+ CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
/* set up a scratch pad */
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+ PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
- SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
+ if (!PL_madskills)
+ SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
SAVESPTR(PL_curstash);
PL_curstash = CopSTASH(PL_curcop);
}
+ /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
SAVESPTR(PL_beginav);
PL_beginav = newAV();
SAVEFREESV(PL_beginav);
- SAVEI32(PL_error_count);
+ SAVESPTR(PL_unitcheckav);
+ PL_unitcheckav = newAV();
+ SAVEFREESV(PL_unitcheckav);
+
+#ifdef PERL_MAD
+ SAVEBOOL(PL_madskills);
+ PL_madskills = 0;
+#endif
/* try to compile it */
- PL_eval_root = Nullop;
- PL_error_count = 0;
+ PL_eval_root = NULL;
PL_curcop = &PL_compiling;
- PL_curcop->cop_arybase = 0;
- if (saveop && saveop->op_flags & OPf_SPECIAL)
+ CopARYBASE_set(PL_curcop, 0);
+ if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpvn(ERRSV,"",0);
- if (yyparse() || PL_error_count || !PL_eval_root) {
+ CLEAR_ERRSV();
+ if (yyparse() || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
I32 optype = 0; /* Might be reset by POPEVAL. */
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
- PL_eval_root = Nullop;
+ PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
if (!startop) {
POPEVAL(cx);
}
lex_end();
- LEAVE;
+ LEAVE; /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
if (optype == OP_REQUIRE) {
const SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
- DIE(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%sCompilation failed in require",
+ *msg ? msg : "Unknown error\n");
}
else if (startop) {
POPBLOCK(cx,PL_curpm);
}
else {
if (!*msg) {
- sv_setpv(ERRSV, "Compilation error");
+ sv_setpvs(ERRSV, "Compilation error");
}
}
PERL_UNUSED_VAR(newsp);
- RETPUSHUNDEF;
+ PUSHs(&PL_sv_undef);
+ PUTBACK;
+ return FALSE;
}
CopLINE_set(&PL_compiling, 0);
if (startop) {
&& cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
== OP_REQUIRE)
scalar(PL_eval_root);
- else if (gimme & G_VOID)
+ else if ((gimme & G_WANT) == G_VOID)
scalarvoid(PL_eval_root);
- else if (gimme & G_ARRAY)
+ else if ((gimme & G_WANT) == G_ARRAY)
list(PL_eval_root);
else
scalar(PL_eval_root);
DEBUG_x(dump_eval());
/* Register with debugger: */
- if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
- CV * const cv = get_cv("DB::postponed", FALSE);
+ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
+ CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
- XPUSHs((SV*)CopFILEGV(&PL_compiling));
+ XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
}
}
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+
/* compiled okay, so do it */
CvDEPTH(PL_compcv) = 1;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
- PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
+ PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
- RETURNOP(PL_eval_start);
+ PUTBACK;
+ return TRUE;
}
STATIC PerlIO *
-S_check_type_and_open(pTHX_ const char *name, const char *mode)
+S_check_type_and_open(pTHX_ const char *name)
{
Stat_t st;
- int st_rc;
- st_rc = PerlLIO_stat(name, &st);
- if (st_rc < 0) {
- return Nullfp;
- }
+ const int st_rc = PerlLIO_stat(name, &st);
- if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
- Perl_die(aTHX_ "%s %s not allowed in require",
- S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
+ PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
+
+ if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
+ return NULL;
}
- return PerlIO_open(name, mode);
+
+ return PerlIO_open(name, PERL_SCRIPT_MODE);
}
+#ifndef PERL_DISABLE_PMC
STATIC PerlIO *
-S_doopen_pm(pTHX_ const char *name, const char *mode)
+S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
{
-#ifndef PERL_DISABLE_PMC
- const STRLEN namelen = strlen(name);
PerlIO *fp;
- if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
- SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
- const char * const pmc = SvPV_nolen_const(pmcsv);
+ PERL_ARGS_ASSERT_DOOPEN_PM;
+
+ if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
+ SV *const pmcsv = newSV(namelen + 2);
+ char *const pmc = SvPVX(pmcsv);
Stat_t pmcstat;
+
+ memcpy(pmc, name, namelen);
+ pmc[namelen] = 'c';
+ pmc[namelen + 1] = '\0';
+
if (PerlLIO_stat(pmc, &pmcstat) < 0) {
- fp = check_type_and_open(name, mode);
+ fp = check_type_and_open(name);
}
else {
- Stat_t pmstat;
- if (PerlLIO_stat(name, &pmstat) < 0 ||
- pmstat.st_mtime < pmcstat.st_mtime)
- {
- fp = check_type_and_open(pmc, mode);
- }
- else {
- fp = check_type_and_open(name, mode);
- }
+ fp = check_type_and_open(pmc);
}
SvREFCNT_dec(pmcsv);
}
else {
- fp = check_type_and_open(name, mode);
+ fp = check_type_and_open(name);
}
return fp;
+}
#else
- return check_type_and_open(name, mode);
+# define doopen_pm(name, namelen) check_type_and_open(name)
#endif /* !PERL_DISABLE_PMC */
-}
PP(pp_require)
{
SV *sv;
const char *name;
STRLEN len;
- const char *tryname = Nullch;
- SV *namesv = Nullsv;
+ char * unixname;
+ STRLEN unixlen;
+#ifdef VMS
+ int vms_unixname = 0;
+#endif
+ const char *tryname = NULL;
+ SV *namesv = NULL;
const I32 gimme = GIMME_V;
- PerlIO *tryrsfp = 0;
int filter_has_file = 0;
- GV *filter_child_proc = 0;
- SV *filter_state = 0;
- SV *filter_sub = 0;
- SV *hook_sv = 0;
+ PerlIO *tryrsfp = NULL;
+ SV *filter_cache = NULL;
+ SV *filter_state = NULL;
+ SV *filter_sub = NULL;
+ SV *hook_sv = NULL;
SV *encoding;
OP *op;
sv = POPs;
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
- if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
- Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
- "v-string in use/require non-portable");
-
sv = new_version(sv);
if (!sv_derived_from(PL_patchlevel, "version"))
- (void *)upg_version(PL_patchlevel);
+ upg_version(PL_patchlevel, TRUE);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
- if ( vcmp(sv,PL_patchlevel) < 0 )
+ if ( vcmp(sv,PL_patchlevel) <= 0 )
DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
- vnormal(sv), vnormal(PL_patchlevel));
+ SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
}
else {
- if ( vcmp(sv,PL_patchlevel) > 0 )
- DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
- vnormal(sv), vnormal(PL_patchlevel));
+ if ( vcmp(sv,PL_patchlevel) > 0 ) {
+ I32 first = 0;
+ AV *lav;
+ SV * const req = SvRV(sv);
+ SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
+
+ /* get the left hand term */
+ lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
+
+ first = SvIV(*av_fetch(lav,0,0));
+ if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
+ || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
+ || av_len(lav) > 1 /* FP with > 3 digits */
+ || strstr(SvPVX(pv),".0") /* FP with leading 0 */
+ ) {
+ DIE(aTHX_ "Perl %"SVf" required--this is only "
+ "%"SVf", stopped", SVfARG(vnormal(req)),
+ SVfARG(vnormal(PL_patchlevel)));
+ }
+ else { /* probably 'use 5.10' or 'use 5.8' */
+ SV * hintsv = newSV(0);
+ I32 second = 0;
+
+ if (av_len(lav)>=1)
+ second = SvIV(*av_fetch(lav,1,0));
+
+ second /= second >= 600 ? 100 : 10;
+ hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
+ (int)first, (int)second,0);
+ upg_version(hintsv, TRUE);
+
+ DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
+ "--this is only %"SVf", stopped",
+ SVfARG(vnormal(req)),
+ SVfARG(vnormal(hintsv)),
+ SVfARG(vnormal(PL_patchlevel)));
+ }
+ }
}
- RETPUSHYES;
+ /* We do this only with use, not require. */
+ if (PL_compcv &&
+ /* If we request a version >= 5.9.5, load feature.pm with the
+ * feature bundle that corresponds to the required version. */
+ vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
+ SV *const importsv = vnormal(sv);
+ *SvPVX_mutable(importsv) = ':';
+ ENTER;
+ Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+ LEAVE;
+ }
+ /* If a version >= 5.11.0 is requested, strictures are on by default! */
+ if (PL_compcv &&
+ vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
+ PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ }
+
+ RETPUSHYES;
}
name = SvPV_const(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
TAINT_PROPER("require");
+
+
+#ifdef VMS
+ /* The key in the %ENV hash is in the syntax of file passed as the argument
+ * usually this is in UNIX format, but sometimes in VMS format, which
+ * can result in a module being pulled in more than once.
+ * To prevent this, the key must be stored in UNIX format if the VMS
+ * name can be translated to UNIX.
+ */
+ if ((unixname = tounixspec(name, NULL)) != NULL) {
+ unixlen = strlen(unixname);
+ vms_unixname = 1;
+ }
+ else
+#endif
+ {
+ /* if not VMS or VMS name can not be translated to UNIX, pass it
+ * through.
+ */
+ unixname = (char *) name;
+ unixlen = len;
+ }
if (PL_op->op_type == OP_REQUIRE) {
- SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
+ unixname, unixlen, 0);
if ( svp ) {
if (*svp != &PL_sv_undef)
RETPUSHYES;
else
- DIE(aTHX_ "Compilation failed in require");
+ DIE(aTHX_ "Attempt to reload %s aborted.\n"
+ "Compilation failed in require", unixname);
}
}
if (path_is_absolute(name)) {
tryname = name;
- tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
- }
-#ifdef MACOS_TRADITIONAL
- if (!tryrsfp) {
- char newname[256];
-
- MacPerl_CanonDir(name, newname, 1);
- if (path_is_absolute(newname)) {
- tryname = newname;
- tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
- }
+ tryrsfp = doopen_pm(name, len);
}
-#endif
if (!tryrsfp) {
AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
- char *unixname;
- if ((unixname = tounixspec(name, Nullch)) != Nullch)
+ if (vms_unixname)
#endif
{
- namesv = NEWSV(806, 0);
+ namesv = newSV_type(SVt_PV);
for (i = 0; i <= AvFILL(ar); i++) {
- SV *dirsv = *av_fetch(ar, i, TRUE);
+ SV * const dirsv = *av_fetch(ar, i, TRUE);
+ if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
+ mg_get(dirsv);
if (SvROK(dirsv)) {
int count;
+ SV **svp;
SV *loader = dirsv;
if (SvTYPE(SvRV(loader)) == SVt_PVAV
&& !sv_isobject(loader))
{
- loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
+ loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
}
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
PTR2UV(SvRV(dirsv)), name);
tryname = SvPVX_const(namesv);
- tryrsfp = 0;
+ tryrsfp = NULL;
ENTER;
SAVETMPS;
count = call_sv(loader, G_ARRAY);
SPAGAIN;
+ /* Adjust file name if the hook has set an %INC entry */
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp)
+ tryname = SvPVX_const(*svp);
+
if (count > 0) {
int i = 0;
SV *arg;
SP -= count - 1;
arg = SP[i++];
- if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
+ if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
+ && !isGV_with_GP(SvRV(arg))) {
+ filter_cache = SvRV(arg);
+ SvREFCNT_inc_simple_void_NN(filter_cache);
+
+ if (i < count) {
+ arg = SP[i++];
+ }
+ }
+
+ if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
arg = SvRV(arg);
}
- if (SvTYPE(arg) == SVt_PVGV) {
- IO *io = GvIO((GV *)arg);
+ if (isGV_with_GP(arg)) {
+ IO * const io = GvIO((const GV *)arg);
++filter_has_file;
if (io) {
tryrsfp = IoIFP(io);
- if (IoTYPE(io) == IoTYPE_PIPE) {
- /* reading from a child process doesn't
- nest -- when returning from reading
- the inner module, the outer one is
- unreadable (closed?) I've tried to
- save the gv to manage the lifespan of
- the pipe, but this didn't help. XXX */
- filter_child_proc = (GV *)arg;
- (void)SvREFCNT_inc(filter_child_proc);
- }
- else {
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
- PerlIO_close(IoOFP(io));
- }
- IoIFP(io) = Nullfp;
- IoOFP(io) = Nullfp;
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ PerlIO_close(IoOFP(io));
}
+ IoIFP(io) = NULL;
+ IoOFP(io) = NULL;
}
if (i < count) {
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
filter_sub = arg;
- (void)SvREFCNT_inc(filter_sub);
+ SvREFCNT_inc_simple_void_NN(filter_sub);
if (i < count) {
filter_state = SP[i];
- (void)SvREFCNT_inc(filter_state);
+ SvREFCNT_inc_simple_void(filter_state);
}
+ }
- if (tryrsfp == 0) {
- tryrsfp = PerlIO_open("/dev/null",
- PERL_SCRIPT_MODE);
- }
+ if (!tryrsfp && (filter_cache || filter_sub)) {
+ tryrsfp = PerlIO_open(BIT_BUCKET,
+ PERL_SCRIPT_MODE);
}
SP--;
}
}
filter_has_file = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- filter_child_proc = 0;
+ if (filter_cache) {
+ SvREFCNT_dec(filter_cache);
+ filter_cache = NULL;
}
if (filter_state) {
SvREFCNT_dec(filter_state);
- filter_state = 0;
+ filter_state = NULL;
}
if (filter_sub) {
SvREFCNT_dec(filter_sub);
- filter_sub = 0;
+ filter_sub = NULL;
}
}
else {
if (!path_is_absolute(name)
-#ifdef MACOS_TRADITIONAL
- /* We consider paths of the form :a:b ambiguous and interpret them first
- as global then as local
- */
- || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
-#endif
) {
- const char *dir = SvPVx_nolen_const(dirsv);
-#ifdef MACOS_TRADITIONAL
- char buf1[256];
- char buf2[256];
+ const char *dir;
+ STRLEN dirlen;
- MacPerl_CanonDir(name, buf2, 1);
- Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
-#else
-# ifdef VMS
+ if (SvOK(dirsv)) {
+ dir = SvPV_const(dirsv, dirlen);
+ } else {
+ dir = "";
+ dirlen = 0;
+ }
+
+#ifdef VMS
char *unixdir;
- if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+ if ((unixdir = tounixpath(dir, NULL)) == NULL)
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
-# else
-# ifdef __SYMBIAN32__
+#else
+# ifdef __SYMBIAN32__
if (PL_origfilename[0] &&
PL_origfilename[1] == ':' &&
!(dir[0] && dir[1] == ':'))
Perl_sv_setpvf(aTHX_ namesv,
"%s\\%s",
dir, name);
-# else
- Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
-# endif
+# else
+ /* The equivalent of
+ Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
+ but without the need to parse the format string, or
+ call strlen on either pointer, and with the correct
+ allocation up front. */
+ {
+ char *tmp = SvGROW(namesv, dirlen + len + 2);
+
+ memcpy(tmp, dir, dirlen);
+ tmp +=dirlen;
+ *tmp++ = '/';
+ /* name came from an SV, so it will have a '\0' at the
+ end that we can copy as part of this memcpy(). */
+ memcpy(tmp, name, len + 1);
+
+ SvCUR_set(namesv, dirlen + len + 1);
+
+ /* Don't even actually have to turn SvPOK_on() as we
+ access it directly with SvPVX() below. */
+ }
# endif
#endif
TAINT_PROPER("require");
tryname = SvPVX_const(namesv);
- tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(tryname, SvCUR(namesv));
if (tryrsfp) {
- if (tryname[0] == '.' && tryname[1] == '/')
- tryname += 2;
+ if (tryname[0] == '.' && tryname[1] == '/') {
+ ++tryname;
+ while (*++tryname == '/');
+ }
break;
}
+ else if (errno == EMFILE)
+ /* no point in trying other paths if out of handles */
+ break;
}
}
}
if (PL_op->op_type == OP_REQUIRE) {
const char *msgstr = name;
if(errno == EMFILE) {
- SV * const msg = sv_2mortal(newSVpv(msgstr,0));
- sv_catpv(msg, ": ");
- sv_catpv(msg, Strerror(errno));
+ SV * const msg
+ = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
+ Strerror(errno)));
msgstr = SvPV_nolen_const(msg);
} else {
if (namesv) { /* did we lookup @INC? */
- SV * const msg = sv_2mortal(newSVpv(msgstr,0));
- SV * const dirmsgsv = NEWSV(0, 0);
AV * const ar = GvAVn(PL_incgv);
I32 i;
- sv_catpvn(msg, " in @INC", 8);
- if (instr(SvPVX_const(msg), ".h "))
- sv_catpv(msg, " (change .h to .ph maybe?)");
- if (instr(SvPVX_const(msg), ".ph "))
- sv_catpv(msg, " (did you run h2ph?)");
- sv_catpv(msg, " (@INC contains:");
+ SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
+ "%s in @INC%s%s (@INC contains:",
+ msgstr,
+ (instr(msgstr, ".h ")
+ ? " (change .h to .ph maybe?)" : ""),
+ (instr(msgstr, ".ph ")
+ ? " (did you run h2ph?)" : "")
+ ));
+
for (i = 0; i <= AvFILL(ar); i++) {
- const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
- Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
- sv_catsv(msg, dirmsgsv);
+ sv_catpvs(msg, " ");
+ sv_catsv(msg, *av_fetch(ar, i, TRUE));
}
- sv_catpvn(msg, ")", 1);
- SvREFCNT_dec(dirmsgsv);
+ sv_catpvs(msg, ")");
msgstr = SvPV_nolen_const(msg);
}
}
/* name is never assigned to again, so len is still strlen(name) */
/* Check whether a hook in @INC has already filled %INC */
if (!hook_sv) {
- (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
} else {
- SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
if (!svp)
- (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
ENTER;
SAVETMPS;
- lex_start(sv_2mortal(newSVpvn("",0)));
- SAVEGENERICSV(PL_rsfp_filters);
- PL_rsfp_filters = NULL;
+ lex_start(NULL, tryrsfp, TRUE);
- PL_rsfp = tryrsfp;
SAVEHINTS();
PL_hints = 0;
- SAVESPTR(PL_compiling.cop_warnings);
+ hv_clear(GvHV(PL_hintgv));
+
+ SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
PL_compiling.cop_warnings = pWARN_NONE ;
- else if (PL_taint_warn)
- PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
else
PL_compiling.cop_warnings = pWARN_STD ;
- SAVESPTR(PL_compiling.cop_io);
- PL_compiling.cop_io = Nullsv;
- if (filter_sub || filter_child_proc) {
- SV * const datasv = filter_add(S_run_user_filter, Nullsv);
+ if (filter_sub || filter_cache) {
+ SV * const datasv = filter_add(S_run_user_filter, NULL);
IoLINES(datasv) = filter_has_file;
- IoFMT_GV(datasv) = (GV *)filter_child_proc;
- IoTOP_GV(datasv) = (GV *)filter_state;
- IoBOTTOM_GV(datasv) = (GV *)filter_sub;
+ IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
+ IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
+ IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
}
/* switch to eval mode */
PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, name, Nullgv);
+ PUSHEVAL(cx, name);
cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
/* Store and reset encoding. */
encoding = PL_encoding;
- PL_encoding = Nullsv;
+ PL_encoding = NULL;
- op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
+ if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
+ op = DOCATCH(PL_eval_start);
+ else
+ op = PL_op->op_next;
/* Restore encoding. */
PL_encoding = encoding;
return op;
}
+/* This is a op added to hold the hints hash for
+ pp_entereval. The hash can be modified by the code
+ being eval'ed, so we return a copy instead. */
+
+PP(pp_hintseval)
+{
+ dVAR;
+ dSP;
+ mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
+ RETURN;
+}
+
+
PP(pp_entereval)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
- dPOPss;
+ SV *sv;
const I32 gimme = GIMME_V;
- const I32 was = PL_sub_generation;
+ const U32 was = PL_breakable_sub_gen;
char tbuf[TYPE_DIGITS(long) + 12];
char *tmpbuf = tbuf;
- char *safestr;
STRLEN len;
- OP *ret;
CV* runcv;
U32 seq;
+ HV *saved_hh = NULL;
- if (!SvPV_nolen_const(sv))
- RETPUSHUNDEF;
+ if (PL_op->op_private & OPpEVAL_HAS_HH) {
+ saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
+ }
+ sv = POPs;
+
+ TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV * const sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
+ SV * const temp_sv = sv_newmortal();
+ Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
(unsigned long)++PL_evalseq,
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
- len = SvCUR(sv);
+ tmpbuf = SvPVX(temp_sv);
+ len = SvCUR(temp_sv);
}
else
- len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
(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 = savepvn(tmpbuf, len);
- SAVEDELETE(PL_defstash, safestr, len);
SAVEHINTS();
PL_hints = PL_op->op_targ;
- SAVESPTR(PL_compiling.cop_warnings);
- if (specialWARN(PL_curcop->cop_warnings))
- PL_compiling.cop_warnings = PL_curcop->cop_warnings;
- else {
- PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
- SAVEFREESV(PL_compiling.cop_warnings);
+ if (saved_hh) {
+ /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
+ SvREFCNT_dec(GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = saved_hh;
}
- SAVESPTR(PL_compiling.cop_io);
- if (specialCopIO(PL_curcop->cop_io))
- PL_compiling.cop_io = PL_curcop->cop_io;
- else {
- PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
- SAVEFREESV(PL_compiling.cop_io);
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ }
+ PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (PL_compiling.cop_hints_hash) {
+ HINTS_REFCNT_LOCK;
+ PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
}
/* special case: an eval '' executed within the DB package gets lexically
* placed in the first non-DB CV rather than the current CV - this
runcv = find_runcv(&seq);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
- PUSHEVAL(cx, 0, Nullgv);
+ PUSHEVAL(cx, 0);
cx->blk_eval.retop = PL_op->op_next;
/* prepare to compile string */
- if (PERLDB_LINE && PL_curstash != PL_debstash)
- save_lines(CopFILEAV(&PL_compiling), PL_linestr);
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
+ save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
PUTBACK;
- ret = doeval(gimme, NULL, runcv, seq);
- if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
- && ret != PL_op->op_next) { /* Successive compilation. */
- strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+
+ if (doeval(gimme, NULL, runcv, seq)) {
+ if (was != PL_breakable_sub_gen /* Some subs defined here. */
+ ? (PERLDB_LINE || PERLDB_SAVESRC)
+ : PERLDB_SAVESRC_NOSUBS) {
+ /* Retain the filegv we created. */
+ } else {
+ char *const safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
+ }
+ return DOCATCH(PL_eval_start);
+ } else {
+ /* We have already left the scope set up earler thanks to the LEAVE
+ in doeval(). */
+ if (was != PL_breakable_sub_gen /* Some subs defined here. */
+ ? (PERLDB_LINE || PERLDB_SAVESRC)
+ : PERLDB_SAVESRC_INVALID) {
+ /* Retain the filegv we created. */
+ } else {
+ (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
+ }
+ return PL_op->op_next;
}
- return DOCATCH(ret);
}
PP(pp_leaveeval)
/* Unassume the success we assumed earlier. */
SV * const nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
/* die_where() did LEAVE, or we won't be here */
}
else {
LEAVE;
- if (!(save_flags & OPf_SPECIAL))
- sv_setpvn(ERRSV,"",0);
+ if (!(save_flags & OPf_SPECIAL)) {
+ CLEAR_ERRSV();
+ }
}
RETURNOP(retop);
}
-PP(pp_entertry)
+/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
+ close to the related Perl_create_eval_scope. */
+void
+Perl_delete_eval_scope(pTHX)
{
- dVAR; dSP;
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ PL_curpm = newpm;
+ LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
+}
+/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
+ also needed by Perl_fold_constants. */
+PERL_CONTEXT *
+Perl_create_eval_scope(pTHX_ U32 flags)
+{
+ PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
ENTER;
SAVETMPS;
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
- PUSHEVAL(cx, 0, 0);
- cx->blk_eval.retop = cLOGOP->op_other->op_next;
+ PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
+ PUSHEVAL(cx, 0);
PL_in_eval = EVAL_INEVAL;
- sv_setpvn(ERRSV,"",0);
- PUTBACK;
+ if (flags & G_KEEPERR)
+ PL_in_eval |= EVAL_KEEPERR;
+ else
+ CLEAR_ERRSV();
+ if (flags & G_FAKINGEVAL) {
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
+ }
+ return cx;
+}
+
+PP(pp_entertry)
+{
+ dVAR;
+ PERL_CONTEXT * const cx = create_eval_scope(0);
+ cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
}
PP(pp_leavetry)
{
dVAR; dSP;
- register SV **mark;
SV **newsp;
PMOP *newpm;
I32 gimme;
if (gimme == G_VOID)
SP = newsp;
else if (gimme == G_SCALAR) {
+ register SV **mark;
MARK = newsp + 1;
if (MARK <= SP) {
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
}
else {
/* in case LEAVE wipes old return values */
+ register SV **mark;
for (mark = newsp + 1; mark <= SP; mark++) {
if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
*mark = sv_mortalcopy(*mark);
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpvn(ERRSV,"",0);
+ CLEAR_ERRSV();
+ RETURN;
+}
+
+PP(pp_entergiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ ENTER;
+ SAVETMPS;
+
+ sv_setsv(PAD_SV(PL_op->op_targ), POPs);
+
+ PUSHBLOCK(cx, CXt_GIVEN, SP);
+ PUSHGIVEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavegiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+ PERL_UNUSED_CONTEXT;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_GIVEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+
+ return NORMAL;
+}
+
+/* Helper routines used by pp_smartmatch */
+STATIC PMOP *
+S_make_matcher(pTHX_ REGEXP *re)
+{
+ dVAR;
+ PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
+
+ PERL_ARGS_ASSERT_MAKE_MATCHER;
+
+ PM_SETRE(matcher, ReREFCNT_inc(re));
+
+ SAVEFREEOP((OP *) matcher);
+ ENTER; SAVETMPS;
+ SAVEOP();
+ return matcher;
+}
+
+STATIC bool
+S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
+{
+ dVAR;
+ dSP;
+
+ PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
+
+ PL_op = (OP *) matcher;
+ XPUSHs(sv);
+ PUTBACK;
+ (void) pp_match();
+ SPAGAIN;
+ return (SvTRUEx(POPs));
+}
+
+STATIC void
+S_destroy_matcher(pTHX_ PMOP *matcher)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_DESTROY_MATCHER;
+ PERL_UNUSED_ARG(matcher);
+
+ FREETMPS;
+ LEAVE;
+}
+
+/* Do a smart match */
+PP(pp_smartmatch)
+{
+ DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
+ return do_smartmatch(NULL, NULL);
+}
+
+/* This version of do_smartmatch() implements the
+ * table of smart matches that is found in perlsyn.
+ */
+STATIC OP *
+S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
+{
+ dVAR;
+ dSP;
+
+ bool object_on_left = FALSE;
+ SV *e = TOPs; /* e is for 'expression' */
+ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
+
+ /* First of all, handle overload magic of the rightmost argument */
+ if (SvAMAGIC(e)) {
+ SV * tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+
+ tmpsv = amagic_call(d, e, smart_amg, 0);
+ if (tmpsv) {
+ SPAGAIN;
+ (void)POPs;
+ SETs(tmpsv);
+ RETURN;
+ }
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
+ }
+
+ SP -= 2; /* Pop the values */
+
+ /* Take care only to invoke mg_get() once for each argument.
+ * Currently we do this by copying the SV if it's magical. */
+ if (d) {
+ if (SvGMAGICAL(d))
+ d = sv_mortalcopy(d);
+ }
+ else
+ d = &PL_sv_undef;
+
+ assert(e);
+ if (SvGMAGICAL(e))
+ e = sv_mortalcopy(e);
+
+ /* ~~ undef */
+ if (!SvOK(e)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
+ if (SvOK(d))
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ }
+
+ if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
+ Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+ }
+ if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
+ object_on_left = TRUE;
+
+ /* ~~ sub */
+ if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
+ I32 c;
+ if (object_on_left) {
+ goto sm_any_sub; /* Treat objects like scalars */
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ /* Test sub truth for each key */
+ HE *he;
+ bool andedresults = TRUE;
+ HV *hv = (HV*) SvRV(d);
+ I32 numkeys = hv_iterinit(hv);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
+ if (numkeys == 0)
+ RETPUSHYES;
+ while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUSHs(hv_iterkeysv(he));
+ PUTBACK;
+ c = call_sv(e, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ andedresults = FALSE;
+ else
+ andedresults = SvTRUEx(POPs) && andedresults;
+ FREETMPS;
+ LEAVE;
+ }
+ if (andedresults)
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ /* Test sub truth for each element */
+ I32 i;
+ bool andedresults = TRUE;
+ AV *av = (AV*) SvRV(d);
+ const I32 len = av_len(av);
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
+ if (len == -1)
+ RETPUSHYES;
+ for (i = 0; i <= len; ++i) {
+ SV * const * const svp = av_fetch(av, i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ if (svp)
+ PUSHs(*svp);
+ PUTBACK;
+ c = call_sv(e, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ andedresults = FALSE;
+ else
+ andedresults = SvTRUEx(POPs) && andedresults;
+ FREETMPS;
+ LEAVE;
+ }
+ if (andedresults)
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ else {
+ sm_any_sub:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUSHs(d);
+ PUTBACK;
+ c = call_sv(e, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_no);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc_void(TOPs);
+ FREETMPS;
+ LEAVE;
+ RETURN;
+ }
+ }
+ /* ~~ %hash */
+ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
+ if (object_on_left) {
+ goto sm_any_hash; /* Treat objects like scalars */
+ }
+ else if (!SvOK(d)) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
+ RETPUSHNO;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ /* Check that the key-sets are identical */
+ HE *he;
+ HV *other_hv = MUTABLE_HV(SvRV(d));
+ bool tied = FALSE;
+ bool other_tied = FALSE;
+ U32 this_key_count = 0,
+ other_key_count = 0;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
+ /* Tied hashes don't know how many keys they have. */
+ if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
+ tied = TRUE;
+ }
+ else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
+ HV * const temp = other_hv;
+ other_hv = hv;
+ hv = temp;
+ tied = TRUE;
+ }
+ if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
+ other_tied = TRUE;
+
+ if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
+ RETPUSHNO;
+
+ /* The hashes have the same number of keys, so it suffices
+ to check that one is a subset of the other. */
+ (void) hv_iterinit(hv);
+ while ( (he = hv_iternext(hv)) ) {
+ SV *key = hv_iterkeysv(he);
+
+ DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
+ ++ this_key_count;
+
+ if(!hv_exists_ent(other_hv, key, 0)) {
+ (void) hv_iterinit(hv); /* reset iterator */
+ RETPUSHNO;
+ }
+ }
+
+ if (other_tied) {
+ (void) hv_iterinit(other_hv);
+ while ( hv_iternext(other_hv) )
+ ++other_key_count;
+ }
+ else
+ other_key_count = HvUSEDKEYS(other_hv);
+
+ if (this_key_count != other_key_count)
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ AV * const other_av = MUTABLE_AV(SvRV(d));
+ const I32 other_len = av_len(other_av) + 1;
+ I32 i;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
+ for (i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
+ if (svp) { /* ??? When can this not happen? */
+ if (hv_exists_ent(hv, *svp, 0))
+ RETPUSHYES;
+ }
+ }
+ RETPUSHNO;
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
+ sm_regex_hash:
+ {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+ HE *he;
+ HV *hv = MUTABLE_HV(SvRV(e));
+
+ (void) hv_iterinit(hv);
+ while ( (he = hv_iternext(hv)) ) {
+ DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
+ if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+ (void) hv_iterinit(hv);
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ }
+ else {
+ sm_any_hash:
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
+ if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ }
+ /* ~~ @array */
+ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
+ if (object_on_left) {
+ goto sm_any_array; /* Treat objects like scalars */
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ AV * const other_av = MUTABLE_AV(SvRV(e));
+ const I32 other_len = av_len(other_av) + 1;
+ I32 i;
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
+ for (i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+
+ DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
+ if (svp) { /* ??? When can this not happen? */
+ if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
+ RETPUSHYES;
+ }
+ }
+ RETPUSHNO;
+ }
+ if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ AV *other_av = MUTABLE_AV(SvRV(d));
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
+ if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
+ RETPUSHNO;
+ else {
+ I32 i;
+ const I32 other_len = av_len(other_av);
+
+ if (NULL == seen_this) {
+ seen_this = newHV();
+ (void) sv_2mortal(MUTABLE_SV(seen_this));
+ }
+ if (NULL == seen_other) {
+ seen_this = newHV();
+ (void) sv_2mortal(MUTABLE_SV(seen_other));
+ }
+ for(i = 0; i <= other_len; ++i) {
+ SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ SV * const * const other_elem = av_fetch(other_av, i, FALSE);
+
+ if (!this_elem || !other_elem) {
+ if (this_elem || other_elem)
+ RETPUSHNO;
+ }
+ else if (hv_exists_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
+ hv_exists_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
+ {
+ if (*this_elem != *other_elem)
+ RETPUSHNO;
+ }
+ else {
+ (void)hv_store_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))),
+ &PL_sv_undef, 0);
+ (void)hv_store_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))),
+ &PL_sv_undef, 0);
+ PUSHs(*other_elem);
+ PUSHs(*this_elem);
+
+ PUTBACK;
+ DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
+ (void) do_smartmatch(seen_this, seen_other);
+ SPAGAIN;
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
+
+ if (!SvTRUEx(POPs))
+ RETPUSHNO;
+ }
+ }
+ RETPUSHYES;
+ }
+ }
+ else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
+ sm_regex_array:
+ {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+ const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
+ I32 i;
+
+ for(i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
+ if (svp && matcher_matches_sv(matcher, *svp)) {
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ }
+ else if (!SvOK(d)) {
+ /* undef ~~ array */
+ const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
+ I32 i;
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
+ for (i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
+ if (!svp || !SvOK(*svp))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ else {
+ sm_any_array:
+ {
+ I32 i;
+ const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
+ for (i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+ if (!svp)
+ continue;
+
+ PUSHs(d);
+ PUSHs(*svp);
+ PUTBACK;
+ /* infinite recursion isn't supposed to happen here */
+ DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
+ (void) do_smartmatch(NULL, NULL);
+ SPAGAIN;
+ DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ }
+ }
+ /* ~~ qr// */
+ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
+ if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+ SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
+ goto sm_regex_hash;
+ }
+ else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+ SV *t = d; d = e; e = t;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
+ goto sm_regex_array;
+ }
+ else {
+ PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
+
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
+ PUTBACK;
+ PUSHs(matcher_matches_sv(matcher, d)
+ ? &PL_sv_yes
+ : &PL_sv_no);
+ destroy_matcher(matcher);
+ RETURN;
+ }
+ }
+ /* ~~ scalar */
+ /* See if there is overload magic on left */
+ else if (object_on_left && SvAMAGIC(d)) {
+ SV *tmpsv;
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
+ DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
+ if (tmpsv) {
+ SPAGAIN;
+ (void)POPs;
+ SETs(tmpsv);
+ RETURN;
+ }
+ SP -= 2;
+ DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
+ goto sm_any_scalar;
+ }
+ else if (!SvOK(d)) {
+ /* undef ~~ scalar ; we already know that the scalar is SvOK */
+ DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
+ RETPUSHNO;
+ }
+ else
+ sm_any_scalar:
+ if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
+ DEBUG_M(if (SvNIOK(e))
+ Perl_deb(aTHX_ " applying rule Any-Num\n");
+ else
+ Perl_deb(aTHX_ " applying rule Num-numish\n");
+ );
+ /* numeric comparison */
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
+ (void) pp_i_eq();
+ else
+ (void) pp_eq();
+ SPAGAIN;
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+
+ /* As a last resort, use string comparison */
+ DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ return pp_seq();
+}
+
+PP(pp_enterwhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ /* This is essentially an optimization: if the match
+ fails, we don't want to push a context and then
+ pop it again right away, so we skip straight
+ to the op that follows the leavewhen.
+ */
+ if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
+ return cLOGOP->op_other->op_next;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHBLOCK(cx, CXt_WHEN, SP);
+ PUSHWHEN(cx);
+
RETURN;
}
+PP(pp_leavewhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_WHEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+ return NORMAL;
+}
+
+PP(pp_continue)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptowhen(cxstack_ix);
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"continue\" outside a when block");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+ return cx->blk_givwhen.leave_op;
+}
+
+PP(pp_break)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptogiven(cxstack_ix);
+ if (cxix < 0) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ DIE(aTHX_ "Can't use when() outside a topicalizer");
+ else
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+ }
+ if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+ DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+
+ if (CxFOREACH(cx))
+ return CX_LOOP_NEXTOP_GET(cx);
+ else
+ return cx->blk_givwhen.leave_op;
+}
+
STATIC OP *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
register char *s = SvPV_force(sv, len);
- register char *send = s + len;
- register char *base = Nullch;
+ register char * const send = s + len;
+ register char *base = NULL;
register I32 skipspaces = 0;
bool noblank = FALSE;
bool repeat = FALSE;
bool postspace = FALSE;
U32 *fops;
register U32 *fpc;
- U32 *linepc = 0;
+ U32 *linepc = NULL;
register I32 arg;
bool ischop;
bool unchopnum = FALSE;
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
+ PERL_ARGS_ASSERT_DOPARSEFORM;
+
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
maxops += 10;
}
s = base;
- base = Nullch;
+ base = NULL;
Newx(fops, maxops, U32);
fpc = fops;
}
Copy(fops, s, arg, U32);
Safefree(fops);
- sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
+ sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
SvCOMPILED_on(sv);
if (unchopnum && repeat)
dVAR;
SV * const datasv = FILTER_DATA(idx);
const int filter_has_file = IoLINES(datasv);
- GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
- SV * const filter_state = (SV *)IoTOP_GV(datasv);
- SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
- int len = 0;
+ SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
+ SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
+ int status = 0;
+ SV *upstream;
+ STRLEN got_len;
+ const char *got_p = NULL;
+ const char *prune_from = NULL;
+ bool read_from_cache = FALSE;
+ STRLEN umaxlen;
+
+ PERL_ARGS_ASSERT_RUN_USER_FILTER;
+
+ assert(maxlen >= 0);
+ umaxlen = maxlen;
/* I was having segfault trouble under Linux 2.2.5 after a
parse error occured. (Had to hack around it with a test
- for PL_error_count == 0.) Solaris doesn't segfault --
+ for PL_parser->error_count == 0.) Solaris doesn't segfault --
not sure where the trouble is yet. XXX */
+ if (IoFMT_GV(datasv)) {
+ SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
+ if (SvOK(cache)) {
+ STRLEN cache_len;
+ const char *cache_p = SvPV(cache, cache_len);
+ STRLEN take = 0;
+
+ if (umaxlen) {
+ /* Running in block mode and we have some cached data already.
+ */
+ if (cache_len >= umaxlen) {
+ /* In fact, so much data we don't even need to call
+ filter_read. */
+ take = umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(cache_p, '\n', cache_len);
+ if (first_nl) {
+ take = first_nl + 1 - cache_p;
+ }
+ }
+ if (take) {
+ sv_catpvn(buf_sv, cache_p, take);
+ sv_chop(cache, cache_p + take);
+ /* Definately not EOF */
+ return 1;
+ }
+
+ sv_catsv(buf_sv, cache);
+ if (umaxlen) {
+ umaxlen -= cache_len;
+ }
+ SvOK_off(cache);
+ read_from_cache = TRUE;
+ }
+ }
+
+ /* Filter API says that the filter appends to the contents of the buffer.
+ Usually the buffer is "", so the details don't matter. But if it's not,
+ then clearly what it contains is already filtered by this filter, so we
+ don't want to pass it in a second time.
+ I'm going to use a mortal in case the upstream filter croaks. */
+ upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
+ ? sv_newmortal() : buf_sv;
+ SvUPGRADE(upstream, SVt_PV);
+
if (filter_has_file) {
- len = FILTER_READ(idx+1, buf_sv, maxlen);
+ status = FILTER_READ(idx+1, upstream, 0);
}
- if (filter_sub && len >= 0) {
+ if (filter_sub && status >= 0) {
dSP;
int count;
SAVETMPS;
EXTEND(SP, 2);
- DEFSV = buf_sv;
+ DEFSV_set(upstream);
PUSHMARK(SP);
- PUSHs(sv_2mortal(newSViv(maxlen)));
+ mPUSHi(0);
if (filter_state) {
PUSHs(filter_state);
}
if (count > 0) {
SV *out = POPs;
if (SvOK(out)) {
- len = SvIV(out);
+ status = SvIV(out);
}
}
LEAVE;
}
- if (len <= 0) {
- IoLINES(datasv) = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- IoFMT_GV(datasv) = Nullgv;
+ if(SvOK(upstream)) {
+ got_p = SvPV(upstream, got_len);
+ if (umaxlen) {
+ if (got_len > umaxlen) {
+ prune_from = got_p + umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(got_p, '\n', got_len);
+ if (first_nl && first_nl + 1 < got_p + got_len) {
+ /* There's a second line here... */
+ prune_from = first_nl + 1;
+ }
}
+ }
+ if (prune_from) {
+ /* Oh. Too long. Stuff some in our cache. */
+ STRLEN cached_len = got_p + got_len - prune_from;
+ SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
+
+ if (!cache) {
+ IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
+ } else if (SvOK(cache)) {
+ /* Cache should be empty. */
+ assert(!SvCUR(cache));
+ }
+
+ sv_setpvn(cache, prune_from, cached_len);
+ /* If you ask for block mode, you may well split UTF-8 characters.
+ "If it breaks, you get to keep both parts"
+ (Your code is broken if you don't put them back together again
+ before something notices.) */
+ if (SvUTF8(upstream)) {
+ SvUTF8_on(cache);
+ }
+ SvCUR_set(upstream, got_len - cached_len);
+ /* Can't yet be EOF */
+ if (status == 0)
+ status = 1;
+ }
+
+ /* If they are at EOF but buf_sv has something in it, then they may never
+ have touched the SV upstream, so it may be undefined. If we naively
+ concatenate it then we get a warning about use of uninitialised value.
+ */
+ if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+ sv_catsv(buf_sv, upstream);
+ }
+
+ if (status <= 0) {
+ IoLINES(datasv) = 0;
+ SvREFCNT_dec(IoFMT_GV(datasv));
if (filter_state) {
SvREFCNT_dec(filter_state);
- IoTOP_GV(datasv) = Nullgv;
+ IoTOP_GV(datasv) = NULL;
}
if (filter_sub) {
SvREFCNT_dec(filter_sub);
- IoBOTTOM_GV(datasv) = Nullgv;
+ IoBOTTOM_GV(datasv) = NULL;
}
filter_del(S_run_user_filter);
}
-
- return len;
+ if (status == 0 && read_from_cache) {
+ /* If we read some data from the cache (and by getting here it implies
+ that we emptied the cache) then we aren't yet at EOF, and mustn't
+ report that to our caller. */
+ return 1;
+ }
+ return status;
}
/* perhaps someone can come up with a better name for
this? it is not really "absolute", per se ... */
static bool
-S_path_is_absolute(pTHX_ const char *name)
+S_path_is_absolute(const char *name)
{
+ PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
+
if (PERL_FILE_IS_ABSOLUTE(name)
-#ifdef MACOS_TRADITIONAL
- || (*name == ':')
+#ifdef WIN32
+ || (*name == '.' && ((name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/'))
+ || (name[1] == '\\' ||
+ ( name[1] == '.' && name[2] == '\\')))
+ )
#else
|| (*name == '.' && (name[1] == '/' ||
(name[1] == '.' && name[2] == '/')))
projects / p5sagit/p5-mst-13.2.git / blobdiff