/* pp_ctl.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
+
PP(pp_wantarray)
{
dVAR;
dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
SV *tmpstr;
- MAGIC *mg = NULL;
+ 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;
if (SvROK(tmpstr)) {
SV * const sv = SvRV(tmpstr);
- if(SvMAGICAL(sv))
- mg = mg_find(sv, PERL_MAGIC_qr);
+ if (SvTYPE(sv) == SVt_REGEXP)
+ re = (REGEXP*) sv;
}
- if (mg) {
- regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
+ if (re) {
+ re = reg_temp_copy(re);
ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, re);
}
else {
STRLEN len;
- const char *t = SvPV_const(tmpstr, len);
- regexp * const re = PM_GETRE(pm);
+ 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 (!re || !re->precomp || re->prelen != (I32)len ||
- memNE(re->precomp, t, len))
+ if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
+ memNE(RX_PRECOMP(re), t, len))
{
- const regexp_engine *eng = re ? re->engine : NULL;
-
+ 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 (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);
}
- if (eng)
- PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm));
- else
- PM_SETRE(pm, CALLREGCOMP((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 (PM_GETRE(pm)->extflags & RXf_WHITE)
- 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;
}
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(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)
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);
}
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->offs[0].start + 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->offs[0].end + orig;
+ cx->sb_s = RX_OFFS(rx)[0].end + orig;
{ /* Update the pos() information. */
SV * const sv = cx->sb_targ;
MAGIC *mg;
- I32 i;
SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
#ifdef PERL_OLD_COPY_ON_WRITE
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;
+
+ PERL_ARGS_ASSERT_RXRES_SAVE;
PERL_UNUSED_CONTEXT;
- if (!p || p[1] < rx->nparens) {
+ 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 : NULL);
+ *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 = NULL;
+ *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->offs[i].start;
- *p++ = (UV)rx->offs[i].end;
+ *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;
}
}
{
UV *p = (UV*)*rsp;
U32 i;
+
+ PERL_ARGS_ASSERT_RXRES_RESTORE;
PERL_UNUSED_CONTEXT;
RX_MATCH_COPY_FREE(rx);
*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->offs[i].start = (I32)(*p++);
- rx->offs[i].end = (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++);
}
}
Perl_rxres_free(pTHX_ void **rsp)
{
UV * const p = (UV*)*rsp;
+
+ PERL_ARGS_ASSERT_RXRES_FREE;
PERL_UNUSED_CONTEXT;
if (p) {
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)) {
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_flags(PL_formtarget, 0);
+ } 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;
}
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;
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpvn(TARG, "", 0);
+ sv_setpvs(TARG, "");
SETs(targ);
RETURN;
}
static const char * const context_name[] = {
"pseudo-block",
+ "when",
+ NULL, /* CXt_BLOCK never actually needs "block" */
+ "given",
+ 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",
- "given",
- "when"
};
STATIC I32
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));
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)
-{
- dVAR;
- 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)) {
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;
}
case CXt_GIVEN:
DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
return i;
- case CXt_LOOP:
+ 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;
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:
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, SVfARG(err));
- ++PL_error_count;
+ if (PL_parser)
+ ++PL_parser->error_count;
}
OP *
SV * const err = ERRSV;
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);
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) {
if (isGV(cvgv)) {
SV * const sv = newSV(0);
gv_efullname3(sv, cvgv, NULL);
- PUSHs(sv_2mortal(sv));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+ mPUSHs(sv);
+ PUSHs(boolSV(CxHASARGS(cx)));
}
else {
- PUSHs(sv_2mortal(newSVpvs("(unknown)")));
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+ PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
+ PUSHs(boolSV(CxHASARGS(cx)));
}
}
else {
- PUSHs(sv_2mortal(newSVpvs("(eval)")));
- 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;
/* 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(CopHINTS_get(cx->blk_oldcop))));
+ mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
}
else
mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
- PUSHs(sv_2mortal(mask));
+ mPUSHs(mask);
}
PUSHs(cx->blk_oldcop->cop_hints_hash ?
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
SV **svp;
- U16 cxtype = CXt_LOOP | CXp_FOREACH;
+ 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 {
SAVEGENERICSV(*svp);
*svp = newSV(0);
#ifdef USE_ITHREADS
- iterdata = (void*)gv;
+ iterdata = (PAD*)gv;
#endif
}
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;
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
- if (clear_errsv)
- sv_setpvn(ERRSV,"",0);
+ if (clear_errsv) {
+ CLEAR_ERRSV();
+ }
return retop;
}
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.my_op->op_lastop->op_next;
break;
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;
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) {
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;
}
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;
else {
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 = CvDEPTH(cv);
if (CvDEPTH(cv) < 2)
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* const av = (AV*)PAD_SVl(0);
+ AV *const av = MUTABLE_AV(PAD_SVl(0));
cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
+ GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
break;
}
/* else fall through */
- case CXt_LOOP:
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
gotoprobe = cx->blk_oldcop->op_sibling;
break;
case CXt_SUBST:
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_type(SVt_PVMG);
}
}
-STATIC void
-S_docatch_body(pTHX)
-{
- dVAR;
- CALLRUNOPS(aTHX);
- return;
-}
-
STATIC OP *
S_docatch(pTHX_ OP *o)
{
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 */
I32 gimme = G_VOID;
I32 optype;
OP dummy;
- OP *rop;
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
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 */
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, NULL);
+ 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_simple(PL_comppad);
+ *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
LEAVE;
if (IN_PERL_COMPILETIME)
CopHINTS_set(&PL_compiling, PL_hints);
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
- return rop;
+ return PL_eval_start;
}
* 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).
*/
-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_type(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_simple(outside);
+ CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
/* set up a scratch pad */
SAVESPTR(PL_unitcheckav);
PL_unitcheckav = newAV();
SAVEFREESV(PL_unitcheckav);
- SAVEI32(PL_error_count);
#ifdef PERL_MAD
- SAVEI32(PL_madskills);
+ SAVEBOOL(PL_madskills);
PL_madskills = 0;
#endif
/* try to compile it */
PL_eval_root = NULL;
- PL_error_count = 0;
PL_curcop = &PL_compiling;
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. */
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);
}
}
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);
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;
const int st_rc = PerlLIO_stat(name, &st);
+ 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 {
- fp = check_type_and_open(pmc, 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;
+ char * unixname;
+ STRLEN unixlen;
+#ifdef VMS
+ int vms_unixname = 0;
+#endif
const char *tryname = NULL;
SV *namesv = NULL;
const I32 gimme = GIMME_V;
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"))
upg_version(PL_patchlevel, TRUE);
SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
}
else {
- if ( vcmp(sv,PL_patchlevel) > 0 )
- DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
- SVfARG(vnormal(sv)), SVfARG(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)));
+ }
+ }
}
- /* If we request a version >= 5.9.5, load feature.pm with the
- * feature bundle that corresponds to the required version.
- * We do this only with use, not require. */
- if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
+ /* 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;
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);
+ tryrsfp = doopen_pm(name, len);
}
#ifdef MACOS_TRADITIONAL
if (!tryrsfp) {
MacPerl_CanonDir(name, newname, 1);
if (path_is_absolute(newname)) {
tryname = newname;
- tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(newname, strlen(newname));
}
}
#endif
AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
- char *unixname;
- if ((unixname = tounixspec(name, NULL)) != NULL)
+ if (vms_unixname)
#endif
{
- namesv = newSV(0);
+ namesv = newSV_type(SVt_PV);
for (i = 0; i <= AvFILL(ar); i++) {
SV * const dirsv = *av_fetch(ar, i, TRUE);
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",
}
}
- if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
+ if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
arg = SvRV(arg);
}
- if (SvTYPE(arg) == SVt_PVGV) {
+ if (isGV_with_GP(arg)) {
IO * const io = GvIO((GV *)arg);
++filter_has_file;
|| (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
#endif
) {
- const char *dir = SvPVx_nolen_const(dirsv);
+ const char *dir;
+ STRLEN dirlen;
+
+ if (SvOK(dirsv)) {
+ dir = SvPV_const(dirsv, dirlen);
+ } else {
+ dir = "";
+ dirlen = 0;
+ }
+
#ifdef MACOS_TRADITIONAL
char buf1[256];
char buf2[256];
"%s\\%s",
dir, name);
# else
- Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
+ /* 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
#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;
/* 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_simple(hook_sv), 0 );
+ (void)hv_store(GvHVn(PL_incgv),
+ unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
ENTER;
SAVETMPS;
- lex_start(NULL);
- SAVEGENERICSV(PL_rsfp_filters);
- PL_rsfp_filters = NULL;
+ lex_start(NULL, tryrsfp, TRUE);
- PL_rsfp = tryrsfp;
SAVEHINTS();
PL_hints = 0;
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
+ }
+
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
/* switch to eval mode */
PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, name, NULL);
+ PUSHEVAL(cx, name);
cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
encoding = PL_encoding;
PL_encoding = NULL;
- op = DOCATCH(doeval(gimme, NULL, NULL, 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((SV*)Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv)));
+ RETURN;
+}
+
+
PP(pp_entereval)
{
dVAR; dSP;
char *tmpbuf = tbuf;
char *safestr;
STRLEN len;
- OP *ret;
+ bool ok;
CV* runcv;
U32 seq;
HV *saved_hh = NULL;
const int fakelen = 9 + 1;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
- saved_hh = (HV*) SvREFCNT_inc(POPs);
+ saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
sv = POPs;
TAINT_PROPER("eval");
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
runcv = find_runcv(&seq);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
- PUSHEVAL(cx, 0, NULL);
+ 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);
+ save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
PUTBACK;
- ret = doeval(gimme, NULL, runcv, seq);
+ ok = doeval(gimme, NULL, runcv, seq);
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
- && ret != PL_op->op_next) { /* Successive compilation. */
+ && ok) {
/* Copy in anything fake and short. */
my_strlcpy(safestr, fakestr, fakelen);
}
- return DOCATCH(ret);
+ return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
}
PP(pp_leaveeval)
}
else {
LEAVE;
- if (!(save_flags & OPf_SPECIAL))
- sv_setpvn(ERRSV,"",0);
+ if (!(save_flags & OPf_SPECIAL)) {
+ CLEAR_ERRSV();
+ }
}
RETURNOP(retop);
SAVETMPS;
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
- PUSHEVAL(cx, 0, 0);
+ PUSHEVAL(cx, 0);
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpvn(ERRSV,"",0);
+ CLEAR_ERRSV();
if (flags & G_FAKINGEVAL) {
PL_eval_root = PL_op; /* Only needed so that goto works right. */
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpvn(ERRSV,"",0);
+ CLEAR_ERRSV();
RETURN;
}
}
/* Helper routines used by pp_smartmatch */
-STATIC
-PMOP *
-S_make_matcher(pTHX_ regexp *re)
+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
+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);
return (SvTRUEx(POPs));
}
-STATIC
-void
+STATIC void
S_destroy_matcher(pTHX_ PMOP *matcher)
{
dVAR;
+
+ PERL_ARGS_ASSERT_DESTROY_MATCHER;
PERL_UNUSED_ARG(matcher);
+
FREETMPS;
LEAVE;
}
/* This version of do_smartmatch() implements the
* table of smart matches that is found in perlsyn.
*/
-STATIC
-OP *
+STATIC OP *
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
{
dVAR;
SV *e = TOPs; /* e is for 'expression' */
SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
- MAGIC *mg;
- regexp *this_regex, *other_regex;
+ REGEXP *this_regex, *other_regex;
# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
&& NOT_EMPTY_PROTO(This) && (Other = d)))
# define SM_REGEX ( \
- (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
- && (mg = mg_find(This, PERL_MAGIC_qr)) \
- && (this_regex = (regexp *)mg->mg_obj) \
+ (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
+ && (this_regex = (REGEXP*) This) \
&& (Other = e)) \
|| \
- (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
- && (mg = mg_find(This, PERL_MAGIC_qr)) \
- && (this_regex = (regexp *)mg->mg_obj) \
+ (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
+ && (this_regex = (REGEXP*) This) \
&& (Other = d)) )
+# define SM_OBJECT ( \
+ (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
+ || \
+ (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
+
# define SM_OTHER_REF(type) \
(SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
-# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
- && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
- && (other_regex = (regexp *)mg->mg_obj))
-
+# define SM_OTHER_REGEX (SvROK(Other) \
+ && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
+ && (other_regex = (REGEXP*) SvRV(Other)))
+
# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
sv_2mortal(newSViv(PTR2IV(sv))), 0)
if (SvGMAGICAL(e))
e = sv_mortalcopy(e);
+ if (SM_OBJECT)
+ Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+
if (SM_CV_NEP) {
I32 c;
if (SM_OTHER_REF(PVHV)) {
/* Check that the key-sets are identical */
HE *he;
- HV *other_hv = (HV *) SvRV(Other);
+ HV *other_hv = MUTABLE_HV(SvRV(Other));
bool tied = FALSE;
bool other_tied = FALSE;
U32 this_key_count = 0,
}
else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
HV * const temp = other_hv;
- other_hv = (HV *) This;
+ other_hv = MUTABLE_HV(This);
This = (SV *) temp;
tied = TRUE;
}
if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
other_tied = TRUE;
- if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
+ if (!tied && HvUSEDKEYS((const HV *) This) != 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 *) This);
- while ( (he = hv_iternext((HV *) This)) ) {
+ (void) hv_iterinit(MUTABLE_HV(This));
+ while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
I32 key_len;
char * const key = hv_iterkey(he, &key_len);
++ this_key_count;
if(!hv_exists(other_hv, key, key_len)) {
- (void) hv_iterinit((HV *) This); /* reset iterator */
+ (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */
RETPUSHNO;
}
}
RETPUSHYES;
}
else if (SM_OTHER_REF(PVAV)) {
- AV * const other_av = (AV *) SvRV(Other);
+ AV * const other_av = MUTABLE_AV(SvRV(Other));
const I32 other_len = av_len(other_av) + 1;
I32 i;
-
- if (HvUSEDKEYS((HV *) This) != other_len)
- RETPUSHNO;
-
- for(i = 0; i < other_len; ++i) {
+
+ for (i = 0; i < other_len; ++i) {
SV ** const svp = av_fetch(other_av, i, FALSE);
char *key;
STRLEN key_len;
- if (!svp) /* ??? When can this happen? */
- RETPUSHNO;
-
- key = SvPV(*svp, key_len);
- if(!hv_exists((HV *) This, key, key_len))
- RETPUSHNO;
+ if (svp) { /* ??? When can this not happen? */
+ key = SvPV(*svp, key_len);
+ if (hv_exists(MUTABLE_HV(This), key, key_len))
+ RETPUSHYES;
+ }
}
- RETPUSHYES;
+ RETPUSHNO;
}
else if (SM_OTHER_REGEX) {
PMOP * const matcher = make_matcher(other_regex);
HE *he;
- (void) hv_iterinit((HV *) This);
- while ( (he = hv_iternext((HV *) This)) ) {
+ (void) hv_iterinit(MUTABLE_HV(This));
+ while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
- (void) hv_iterinit((HV *) This);
+ (void) hv_iterinit(MUTABLE_HV(This));
destroy_matcher(matcher);
RETPUSHYES;
}
RETPUSHNO;
}
else {
- if (hv_exists_ent((HV *) This, Other, 0))
+ if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
RETPUSHYES;
else
RETPUSHNO;
}
else if (SM_REF(PVAV)) {
if (SM_OTHER_REF(PVAV)) {
- AV *other_av = (AV *) SvRV(Other);
- if (av_len((AV *) This) != av_len(other_av))
+ AV *other_av = MUTABLE_AV(SvRV(Other));
+ if (av_len(MUTABLE_AV(This)) != av_len(other_av))
RETPUSHNO;
else {
I32 i;
(void) sv_2mortal((SV *) seen_other);
}
for(i = 0; i <= other_len; ++i) {
- SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
+ SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
SV * const * const other_elem = av_fetch(other_av, i, FALSE);
if (!this_elem || !other_elem) {
RETPUSHNO;
}
else {
- hv_store_ent(seen_this,
- sv_2mortal(newSViv(PTR2IV(*this_elem))),
- &PL_sv_undef, 0);
- hv_store_ent(seen_other,
- sv_2mortal(newSViv(PTR2IV(*other_elem))),
- &PL_sv_undef, 0);
+ (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(*this_elem);
PUSHs(*other_elem);
}
else if (SM_OTHER_REGEX) {
PMOP * const matcher = make_matcher(other_regex);
- const I32 this_len = av_len((AV *) This);
+ const I32 this_len = av_len(MUTABLE_AV(This));
I32 i;
for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
if (svp && matcher_matches_sv(matcher, *svp)) {
destroy_matcher(matcher);
RETPUSHYES;
else if (SvIOK(Other) || SvNOK(Other)) {
I32 i;
- for(i = 0; i <= AvFILL((AV *) This); ++i) {
- SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
+ SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
if (!svp)
continue;
RETPUSHNO;
}
else if (SvPOK(Other)) {
- const I32 this_len = av_len((AV *) This);
+ const I32 this_len = av_len(MUTABLE_AV(This));
I32 i;
for(i = 0; i <= this_len; ++i) {
- SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
if (!svp)
continue;
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");
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)) {
DEFSV = upstream;
PUSHMARK(SP);
- PUSHs(sv_2mortal(newSViv(0)));
+ mPUSHi(0);
if (filter_state) {
PUSHs(filter_state);
}
static bool
S_path_is_absolute(const char *name)
{
+ PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
+
if (PERL_FILE_IS_ABSOLUTE(name)
#ifdef MACOS_TRADITIONAL
|| (*name == ':')
https://perl5.git.perl.org / perl5.git / blobdiff