Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: blead
Fetching contributors…

Cannot retrieve contributors at this time

5535 lines (4959 sloc) 139.368 kb
/* pp_ctl.c
*
* 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.
*
* [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
* execute the opcodes that make up a perl program. A typical pp function
* expects to find its arguments on the stack, and usually pushes its
* results onto the stack, hence the 'pp' terminology. Each OP structure
* contains a pointer to the relevant pp_foo() function.
*
* Control-oriented means things like pp_enteriter() and pp_next(), which
* alter the flow of control of the program.
*/
#include "EXTERN.h"
#define PERL_IN_PP_CTL_C
#include "perl.h"
#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);
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
RETPUSHUNDEF;
switch (cxstack[cxix].blk_gimme) {
case G_ARRAY:
RETPUSHYES;
case G_SCALAR:
RETPUSHNO;
default:
RETPUSHUNDEF;
}
}
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;
TAINT_NOT;
return NORMAL;
}
PP(pp_regcomp)
{
dVAR;
dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
SV *tmpstr;
REGEXP *re = NULL;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
if (PL_op->op_flags & OPf_STACKED) {
dMARK;
SP = MARK;
}
else
(void)POPs;
RETURN;
}
#endif
#define tryAMAGICregexp(rx) \
STMT_START { \
SvGETMAGIC(rx); \
if (SvROK(rx) && SvAMAGIC(rx)) { \
SV *sv = AMG_CALLunary(rx, regexp_amg); \
if (sv) { \
if (SvROK(sv)) \
sv = SvRV(sv); \
if (SvTYPE(sv) != SVt_REGEXP) \
Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
rx = sv; \
} \
} \
} STMT_END
if (PL_op->op_flags & OPf_STACKED) {
/* multiple args; concatenate them */
dMARK; dORIGMARK;
tmpstr = PAD_SV(ARGTARG);
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
SV *msv = *MARK;
SV *sv;
tryAMAGICregexp(msv);
if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
(sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
{
sv_setsv(tmpstr, sv);
continue;
}
sv_catsv_nomg(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
}
else {
tmpstr = POPs;
tryAMAGICregexp(tmpstr);
}
#undef tryAMAGICregexp
if (SvROK(tmpstr)) {
SV * const sv = SvRV(tmpstr);
if (SvTYPE(sv) == SVt_REGEXP)
re = (REGEXP*) sv;
}
else if (SvTYPE(tmpstr) == SVt_REGEXP)
re = (REGEXP*) tmpstr;
if (re) {
/* The match's LHS's get-magic might need to access this op's reg-
exp (as is sometimes the case with $'; see bug 70764). So we
must call get-magic now before we replace the regexp. Hopeful-
ly this hack can be replaced with the approach described at
http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
/msg122415.html some day. */
if(pm->op_type == OP_MATCH) {
SV *lhs;
const bool was_tainted = PL_tainted;
if (pm->op_flags & OPf_STACKED)
lhs = TOPs;
else if (pm->op_private & OPpTARGET_MY)
lhs = PAD_SV(pm->op_targ);
else lhs = DEFSV;
SvGETMAGIC(lhs);
/* Restore the previous value of PL_tainted (which may have been
modified by get-magic), to avoid incorrectly setting the
RXf_TAINTED flag further down. */
PL_tainted = was_tainted;
}
re = reg_temp_copy(NULL, re);
ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, re);
}
else {
STRLEN len = 0;
const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
re = PM_GETRE(pm);
assert (re != (REGEXP*) &PL_sv_undef);
/* Check against the last compiled regexp. */
if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
memNE(RX_PRECOMP(re), t, len))
{
const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
U32 pm_flags = pm->op_pmflags & RXf_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 = cop_hints_fetch_pvs(PL_curcop, "regcomp", 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. */
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);
}
else if (SvAMAGIC(tmpstr)) {
/* make a copy to avoid extra stringifies */
tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
}
/* If it is gmagical, create a mortal copy, but without calling
get-magic, as we have already done that. */
if(SvGMAGICAL(tmpstr)) {
SV *mortalcopy = sv_newmortal();
sv_setsv_flags(mortalcopy, tmpstr, 0);
tmpstr = mortalcopy;
}
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) {
SvTAINTED_on((SV*)re);
RX_EXTFLAGS(re) |= RXf_TAINTED;
}
}
#endif
if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
pm = PL_curpm;
#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 */
cLOGOP->op_first->op_next = PL_op->op_next;
}
#endif
RETURN;
}
PP(pp_substcont)
{
dVAR;
dSP;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
register PMOP * const pm = (PMOP*) cLOGOP->op_other;
register SV * const dstr = cx->sb_dstr;
register char *s = cx->sb_s;
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP * const rx = cx->sb_rx;
SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
PERL_ASYNC_CHECK();
if(old != rx) {
if(old)
ReREFCNT_dec(old);
PM_SETRE(pm,ReREFCNT_inc(rx));
}
rxres_restore(&cx->sb_rxres, rx);
RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
if (cx->sb_iters++) {
const I32 saviters = cx->sb_iters;
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
/* See "how taint works" above pp_subst() */
if (SvTAINTED(TOPs))
cx->sb_rxtainted |= SUBST_TAINT_REPL;
sv_catsv_nomg(dstr, POPs);
/* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
s -= RX_GOFS(rx);
/* Are we done */
/* I believe that we can't set REXEC_SCREAM here if
SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
equal to s. [See the comment before Perl_re_intuit_start(), which is
called from Perl_regexec_flags(), which says that it should be when
SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
during the match. */
if (CxONCE(cx) || s < orig ||
!CALLREGEXEC(rx, s, cx->sb_strend, orig,
(s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
((cx->sb_rflags & REXEC_COPY_STR)
? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
: (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
{
SV *targ = cx->sb_targ;
assert(cx->sb_strend >= s);
if(cx->sb_strend > s) {
if (DO_UTF8(dstr) && !SvUTF8(targ))
sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
else
sv_catpvn(dstr, s, cx->sb_strend - s);
}
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
if (pm->op_pmflags & PMf_NONDESTRUCT) {
PUSHs(dstr);
/* From here on down we're using the copy, and leaving the
original untouched. */
targ = dstr;
}
else {
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(targ)) {
sv_force_normal_flags(targ, SV_COW_DROP_PV);
} else
#endif
{
SvPV_free(targ);
}
SvPV_set(targ, SvPVX(dstr));
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
if (DO_UTF8(dstr))
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
}
/* update the taint state of various various variables in
* preparation for final exit.
* See "how taint works" above pp_subst() */
if (PL_tainting) {
if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
== (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
)
(RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
&& (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
)
SvTAINTED_on(TOPs); /* taint return value */
/* needed for mg_set below */
PL_tainted = cBOOL(cx->sb_rxtainted &
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
SvTAINT(TARG);
}
/* PL_tainted must be correctly set for this mg_set */
SvSETMAGIC(TARG);
TAINT_NOT;
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
/* NOTREACHED */
}
cx->sb_iters = saviters;
}
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
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(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(rx)[0].end + orig;
{ /* Update the pos() information. */
SV * const sv
= (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
MAGIC *mg;
SvUPGRADE(sv, SVt_PVMG);
if (!(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);
}
mg->mg_len = m - orig;
}
if (old != rx)
(void)ReREFCNT_inc(rx);
/* update the taint state of various various variables in preparation
* for calling the code block.
* See "how taint works" above pp_subst() */
if (PL_tainting) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
== (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
)
(RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
if (cx->sb_iters > 1 && (cx->sb_rxtainted &
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
? cx->sb_dstr : cx->sb_targ);
TAINT_NOT;
}
rxres_save(&cx->sb_rxres, rx);
PL_curpm = pm;
RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
}
void
Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
{
UV *p = (UV*)*rsp;
U32 i;
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(rx) * 2;
#else
i = 6 + RX_NPARENS(rx) * 2;
#endif
if (!p)
Newx(p, i, UV);
else
Renew(p, i, UV);
*rsp = (void*)p;
}
*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));
RX_SAVED_COPY(rx) = NULL;
#endif
*p++ = RX_NPARENS(rx);
*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;
}
}
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(rx))
SvREFCNT_dec (RX_SAVED_COPY(rx));
RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
*p++ = 0;
#endif
RX_NPARENS(rx) = *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++);
}
}
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)
PoisonFree(*p, 1, sizeof(*p));
#else
Safefree(INT2PTR(char*,*p));
#endif
#ifdef PERL_OLD_COPY_ON_WRITE
if (p[1]) {
SvREFCNT_dec (INT2PTR(SV*,p[1]));
}
#endif
Safefree(p);
*rsp = NULL;
}
}
#define FORM_NUM_BLANK (1<<30)
#define FORM_NUM_POINT (1<<29)
PP(pp_formline)
{
dVAR; dSP; dMARK; dORIGMARK;
register SV * const tmpForm = *++MARK;
SV *formsv; /* contains text of original format */
register U32 *fpc; /* format ops program counter */
register char *t; /* current append position in target string */
const char *f; /* current position in format string */
register I32 arg;
register SV *sv = NULL; /* current item */
const char *item = NULL;/* string value of current item */
I32 itemsize = 0; /* length of current item, possibly truncated */
I32 fieldsize = 0; /* width of current field */
I32 lines = 0; /* number of lines that have been output */
bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
const char *chophere = NULL; /* where to chop current item */
STRLEN linemark = 0; /* pos of start of line in output */
NV value;
bool gotsome = FALSE; /* seen at least one non-blank item on this line */
STRLEN len;
STRLEN linemax; /* estimate of output size in bytes */
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
const char *fmt;
MAGIC *mg = NULL;
U8 *source; /* source of bytes to append */
STRLEN to_copy; /* how may bytes to append */
char trans; /* what chars to translate */
mg = doparseform(tmpForm);
fpc = (U32*)mg->mg_ptr;
/* the actual string the format was compiled from.
* with overload etc, this may not match tmpForm */
formsv = mg->mg_obj;
SvPV_force(PL_formtarget, len);
if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
t = SvGROW(PL_formtarget, len + linemax + 1);
/* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
t += len;
f = SvPV_const(formsv, len);
for (;;) {
DEBUG_f( {
const char *name = "???";
arg = -1;
switch (*fpc) {
case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
case FF_CHECKNL: name = "CHECKNL"; break;
case FF_CHECKCHOP: name = "CHECKCHOP"; break;
case FF_SPACE: name = "SPACE"; break;
case FF_HALFSPACE: name = "HALFSPACE"; break;
case FF_ITEM: name = "ITEM"; break;
case FF_CHOP: name = "CHOP"; break;
case FF_LINEGLOB: name = "LINEGLOB"; break;
case FF_NEWLINE: name = "NEWLINE"; break;
case FF_MORE: name = "MORE"; break;
case FF_LINEMARK: name = "LINEMARK"; break;
case FF_END: name = "END"; break;
case FF_0DECIMAL: name = "0DECIMAL"; break;
case FF_LINESNGL: name = "LINESNGL"; break;
}
if (arg >= 0)
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
else
PerlIO_printf(Perl_debug_log, "%-16s\n", name);
} );
switch (*fpc++) {
case FF_LINEMARK:
linemark = t - SvPVX(PL_formtarget);
lines++;
gotsome = FALSE;
break;
case FF_LITERAL:
to_copy = *fpc++;
source = (U8 *)f;
f += to_copy;
trans = '~';
item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
goto append;
case FF_SKIP:
f += *fpc++;
break;
case FF_FETCH:
arg = *fpc++;
f += arg;
fieldsize = arg;
if (MARK < SP)
sv = *++MARK;
else {
sv = &PL_sv_no;
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
}
if (SvTAINTED(sv))
SvTAINTED_on(PL_formtarget);
break;
case FF_CHECKNL:
{
const char *send;
const char *s = item = SvPV_const(sv, len);
itemsize = len;
if (DO_UTF8(sv)) {
itemsize = sv_len_utf8(sv);
if (itemsize != (I32)len) {
I32 itembytes;
if (itemsize > fieldsize) {
itemsize = fieldsize;
itembytes = itemsize;
sv_pos_u2b(sv, &itembytes, 0);
}
else
itembytes = len;
send = chophere = s + itembytes;
while (s < send) {
if (*s & ~31)
gotsome = TRUE;
else if (*s == '\n')
break;
s++;
}
item_is_utf8 = TRUE;
itemsize = s - item;
sv_pos_b2u(sv, &itemsize);
break;
}
}
item_is_utf8 = FALSE;
if (itemsize > fieldsize)
itemsize = fieldsize;
send = chophere = s + itemsize;
while (s < send) {
if (*s & ~31)
gotsome = TRUE;
else if (*s == '\n')
break;
s++;
}
itemsize = s - item;
break;
}
case FF_CHECKCHOP:
{
const char *s = item = SvPV_const(sv, len);
itemsize = len;
if (DO_UTF8(sv)) {
itemsize = sv_len_utf8(sv);
if (itemsize != (I32)len) {
I32 itembytes;
if (itemsize <= fieldsize) {
const char *send = chophere = s + itemsize;
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
chophere = s;
break;
}
if (*s++ & ~31)
gotsome = TRUE;
}
}
else {
const char *send;
itemsize = fieldsize;
itembytes = itemsize;
sv_pos_u2b(sv, &itembytes, 0);
send = chophere = s + itembytes;
while (s < send || (s == send && isSPACE(*s))) {
if (isSPACE(*s)) {
if (chopspace)
chophere = s;
if (*s == '\r')
break;
}
else {
if (*s & ~31)
gotsome = TRUE;
if (strchr(PL_chopset, *s))
chophere = s + 1;
}
s++;
}
itemsize = chophere - item;
sv_pos_b2u(sv, &itemsize);
}
item_is_utf8 = TRUE;
break;
}
}
item_is_utf8 = FALSE;
if (itemsize <= fieldsize) {
const char *const send = chophere = s + itemsize;
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
chophere = s;
break;
}
if (*s++ & ~31)
gotsome = TRUE;
}
}
else {
const char *send;
itemsize = fieldsize;
send = chophere = s + itemsize;
while (s < send || (s == send && isSPACE(*s))) {
if (isSPACE(*s)) {
if (chopspace)
chophere = s;
if (*s == '\r')
break;
}
else {
if (*s & ~31)
gotsome = TRUE;
if (strchr(PL_chopset, *s))
chophere = s + 1;
}
s++;
}
itemsize = chophere - item;
}
break;
}
case FF_SPACE:
arg = fieldsize - itemsize;
if (arg) {
fieldsize -= arg;
while (arg-- > 0)
*t++ = ' ';
}
break;
case FF_HALFSPACE:
arg = fieldsize - itemsize;
if (arg) {
arg /= 2;
fieldsize -= arg;
while (arg-- > 0)
*t++ = ' ';
}
break;
case FF_ITEM:
to_copy = itemsize;
source = (U8 *)item;
trans = 1;
if (item_is_utf8) {
/* convert to_copy from chars to bytes */
U8 *s = source;
while (to_copy--)
s += UTF8SKIP(s);
to_copy = s - source;
}
goto append;
case FF_CHOP:
{
const char *s = chophere;
if (chopspace) {
while (isSPACE(*s))
s++;
}
sv_chop(sv,s);
SvSETMAGIC(sv);
break;
}
case FF_LINESNGL:
chopspace = 0;
case FF_LINEGLOB:
{
const bool oneline = fpc[-1] == FF_LINESNGL;
const char *s = item = SvPV_const(sv, len);
const char *const send = s + len;
item_is_utf8 = DO_UTF8(sv);
if (!len)
break;
trans = 0;
gotsome = TRUE;
chophere = s + len;
source = (U8 *) s;
to_copy = len;
while (s < send) {
if (*s++ == '\n') {
if (oneline) {
to_copy = s - SvPVX_const(sv) - 1;
chophere = s;
break;
} else {
if (s == send) {
to_copy--;
} else
lines++;
}
}
}
}
append:
/* append to_copy bytes from source to PL_formstring.
* item_is_utf8 implies source is utf8.
* if trans, translate certain characters during the copy */
{
U8 *tmp = NULL;
STRLEN grow = 0;
SvCUR_set(PL_formtarget,
t - SvPVX_const(PL_formtarget));
if (targ_is_utf8 && !item_is_utf8) {
source = tmp = bytes_to_utf8(source, &to_copy);
} else {
if (item_is_utf8 && !targ_is_utf8) {
U8 *s;
/* Upgrade targ to UTF8, and then we reduce it to
a problem we have a simple solution for.
Don't need get magic. */
sv_utf8_upgrade_nomg(PL_formtarget);
targ_is_utf8 = TRUE;
/* re-calculate linemark */
s = (U8*)SvPVX(PL_formtarget);
/* the bytes we initially allocated to append the
* whole line may have been gobbled up during the
* upgrade, so allocate a whole new line's worth
* for safety */
grow = linemax;
while (linemark--)
s += UTF8SKIP(s);
linemark = s - (U8*)SvPVX(PL_formtarget);
}
/* Easy. They agree. */
assert (item_is_utf8 == targ_is_utf8);
}
if (!trans)
/* @* and ^* are the only things that can exceed
* the linemax, so grow by the output size, plus
* a whole new form's worth in case of any further
* output */
grow = linemax + to_copy;
if (grow)
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
Copy(source, t, to_copy, char);
if (trans) {
/* blank out ~ or control chars, depending on trans.
* works on bytes not chars, so relies on not
* matching utf8 continuation bytes */
U8 *s = (U8*)t;
U8 *send = s + to_copy;
while (s < send) {
const int ch = *s;
if (trans == '~' ? (ch == '~') :
#ifdef EBCDIC
iscntrl(ch)
#else
(!(ch & ~31))
#endif
)
*s = ' ';
s++;
}
}
t += to_copy;
SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
if (tmp)
Safefree(tmp);
break;
}
case FF_0DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
((arg & FORM_NUM_POINT) ?
"%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
#else
fmt = (const char *)
((arg & FORM_NUM_POINT) ?
"%#0*.*f" : "%0*.*f");
#endif
goto ff_dec;
case FF_DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
#else
fmt = (const char *)
((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
#endif
ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
arg = fieldsize;
while (arg--)
*t++ = ' ';
break;
}
gotsome = TRUE;
value = SvNV(sv);
/* overflow evidence */
if (num_overflow(value, fieldsize, arg)) {
arg = fieldsize;
while (arg--)
*t++ = '#';
break;
}
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
break;
case FF_NEWLINE:
f++;
while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
t++;
*t++ = '\n';
break;
case FF_BLANK:
arg = *fpc++;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
fpc--;
goto end;
}
}
else {
t = SvPVX(PL_formtarget) + linemark;
lines--;
}
break;
case FF_MORE:
{
const char *s = chophere;
const char *send = item + len;
if (chopspace) {
while (isSPACE(*s) && (s < send))
s++;
}
if (s < send) {
char *s1;
arg = fieldsize - itemsize;
if (arg) {
fieldsize -= arg;
while (arg-- > 0)
*t++ = ' ';
}
s1 = t - 3;
if (strnEQ(s1," ",3)) {
while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
s1--;
}
*s1++ = '.';
*s1++ = '.';
*s1++ = '.';
}
break;
}
case FF_END:
end:
assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
SP = ORIGMARK;
if (fpc[-1] == FF_BLANK)
RETURNOP(cLISTOP->op_first);
else
RETPUSHYES;
}
}
}
PP(pp_grepstart)
{
dVAR; dSP;
SV *src;
if (PL_stack_base + *PL_markstack_ptr == SP) {
(void)POPMARK;
if (GIMME_V == G_SCALAR)
mXPUSHi(0);
RETURNOP(PL_op->op_next->op_next);
}
PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
Perl_pp_pushmark(aTHX); /* push dst */
Perl_pp_pushmark(aTHX); /* push src */
ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
if (PL_op->op_private & OPpGREP_LEX)
SAVESPTR(PAD_SVl(PL_op->op_targ));
else
SAVE_DEFSV;
ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
DEFSV_set(src);
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
Perl_pp_pushmark(aTHX); /* push top */
return ((LOGOP*)PL_op->op_next)->op_other;
}
PP(pp_mapwhile)
{
dVAR; dSP;
const I32 gimme = GIMME_V;
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
SV** src;
SV** dst;
/* first, move source pointer to the next item in the source list */
++PL_markstack_ptr[-1];
/* if there are new items, push them into the destination list */
if (items && gimme != G_VOID) {
/* might need to make room back there first */
if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
/* XXX this implementation is very pessimal because the stack
* is repeatedly extended for every set of items. Is possible
* to do this without any stack extension or copying at all
* by maintaining a separate list over which the map iterates
* (like foreach does). --gsar */
/* everything in the stack after the destination list moves
* towards the end the stack by the amount of room needed */
shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
/* items to shift up (accounting for the moved source pointer) */
count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
/* This optimization is by Ben Tilly and it does
* things differently from what Sarathy (gsar)
* is describing. The downside of this optimization is
* that leaves "holes" (uninitialized and hopefully unused areas)
* to the Perl stack, but on the other hand this
* shouldn't be a problem. If Sarathy's idea gets
* implemented, this optimization should become
* irrelevant. --jhi */
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */
EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
PL_markstack_ptr[-1] += shift;
*PL_markstack_ptr += shift;
while (count--)
*dst-- = *src--;
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
if (gimme == G_ARRAY) {
/* add returned items to the collection (making mortal copies
* if necessary), then clear the current temps stack frame
* *except* for those items. We do this splicing the items
* into the start of the tmps frame (so some items may be on
* the tmps stack twice), then moving PL_tmps_floor above
* them, then freeing the frame. That way, the only tmps that
* accumulate over iterations are the return values for map.
* We have to do to this way so that everything gets correctly
* freed if we die during the map.
*/
I32 tmpsbase;
I32 i = items;
/* make space for the slice */
EXTEND_MORTAL(items);
tmpsbase = PL_tmps_floor + 1;
Move(PL_tmps_stack + tmpsbase,
PL_tmps_stack + tmpsbase + items,
PL_tmps_ix - PL_tmps_floor,
SV*);
PL_tmps_ix += items;
while (i-- > 0) {
SV *sv = POPs;
if (!SvTEMP(sv))
sv = sv_mortalcopy(sv);
*dst-- = sv;
PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
}
/* clear the stack frame except for the items */
PL_tmps_floor += items;
FREETMPS;
/* FREETMPS may have cleared the TEMP flag on some of the items */
i = items;
while (i-- > 0)
SvTEMP_on(PL_tmps_stack[--tmpsbase]);
}
else {
/* scalar context: we don't care about which values map returns
* (we use undef here). And so we certainly don't want to do mortal
* copies of meaningless values. */
while (items-- > 0) {
(void)POPs;
*dst-- = &PL_sv_undef;
}
FREETMPS;
}
}
else {
FREETMPS;
}
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
(void)POPMARK; /* pop top */
LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop src */
items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
if (PL_op->op_private & OPpGREP_LEX) {
SV* sv = sv_newmortal();
sv_setiv(sv, items);
PUSHs(sv);
}
else {
dTARGET;
XPUSHi(items);
}
}
else if (gimme == G_ARRAY)
SP += items;
RETURN;
}
else {
SV *src;
ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
/* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
SvTEMP_off(src);
if (PL_op->op_private & OPpGREP_LEX)
PAD_SVl(PL_op->op_targ) = src;
else
DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
}
/* Range stuff. */
PP(pp_range)
{
dVAR;
if (GIMME == G_ARRAY)
return NORMAL;
if (SvTRUEx(PAD_SV(PL_op->op_targ)))
return cLOGOP->op_other;
else
return NORMAL;
}
PP(pp_flip)
{
dVAR;
dSP;
if (GIMME == G_ARRAY) {
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
else {
dTOPss;
SV * const targ = PAD_SV(PL_op->op_targ);
int flip = 0;
if (PL_op->op_private & OPpFLIP_LINENUM) {
if (GvIO(PL_last_in_gv)) {
flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
}
else {
GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
if (gv && GvSV(gv))
flip = SvIV(sv) == SvIV(GvSV(gv));
}
} else {
flip = SvTRUE(sv);
}
if (flip) {
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (PL_op->op_flags & OPf_SPECIAL) {
sv_setiv(targ, 1);
SETs(targ);
RETURN;
}
else {
sv_setiv(targ, 0);
SP--;
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
sv_setpvs(TARG, "");
SETs(targ);
RETURN;
}
}
/* This code tries to decide if "$left .. $right" should use the
magical string increment, or if the range is numeric (we make
an exception for .."0" [#18165]). AMS 20021031. */
#define RANGE_IS_NUMERIC(left,right) ( \
SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
(((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
&& (!SvOK(right) || looks_like_number(right))))
PP(pp_flop)
{
dVAR; dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
SvGETMAGIC(left);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(left,right)) {
register IV i, j;
IV max;
if ((SvOK(left) && SvNV(left) < IV_MIN) ||
(SvOK(right) && SvNV(right) > IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV(left);
max = SvIV(right);
if (max >= i) {
j = max - i + 1;
EXTEND_MORTAL(j);
EXTEND(SP, j);
}
else
j = 0;
while (j--) {
SV * const sv = sv_2mortal(newSViv(i++));
PUSHs(sv);
}
}
else {
SV * const final = sv_mortalcopy(right);
STRLEN len;
const char * const tmps = SvPV_const(final, len);
SV *sv = sv_mortalcopy(left);
SvPV_force_nolen(sv);
while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
XPUSHs(sv);
if (strEQ(SvPVX_const(sv),tmps))
break;
sv = sv_2mortal(newSVsv(sv));
sv_inc(sv);
}
}
}
else {
dTOPss;
SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
int flop = 0;
sv_inc(targ);
if (PL_op->op_private & OPpFLIP_LINENUM) {
if (GvIO(PL_last_in_gv)) {
flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
}
else {
GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
}
}
else {
flop = SvTRUE(sv);
}
if (flop) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
sv_catpvs(targ, "E0");
}
SETs(targ);
}
RETURN;
}
/* Control. */
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",
"substitution",
};
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)) {
case CXt_SUBST:
case CXt_SUB:
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
if (CxTYPE(cx) == CXt_NULL)
return -1;
break;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
{
const char *cx_label = CxLABEL(cx);
if (!cx_label || strNE(label, cx_label) ) {
DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
(long)i, cx_label));
continue;
}
DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
return i;
}
}
}
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;
switch (cxstack[cxix].blk_gimme) {
case G_VOID:
return G_VOID;
case G_SCALAR:
return G_SCALAR;
case G_ARRAY:
return G_ARRAY;
default:
Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
/* NOTREACHED */
return 0;
}
}
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 (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
return CxLVAL(cxstack + cxix);
else
return 0;
}
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)) {
default:
continue;
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
return i;
}
}
return i;
}
STATIC I32
S_dopoptoeval(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_EVAL:
DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
return i;
}
}
return 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];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
case CXt_FORMAT:
case CXt_EVAL:
case CXt_NULL:
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
if ((CxTYPE(cx)) == CXt_NULL)
return -1;
break;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%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_ "(dopoptogiven(): found given at cx=%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_ "(dopoptogiven(): found foreach at cx=%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_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
return i;
}
}
return i;
}
void
Perl_dounwind(pTHX_ I32 cxix)
{
dVAR;
I32 optype;
if (!PL_curstackinfo) /* can happen if die during thread cloning */
return;
while (cxstack_ix > cxix) {
SV *sv;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
switch (CxTYPE(cx)) {
case CXt_SUBST:
POPSUBST(cx);
continue; /* not break */
case CXt_SUB:
POPSUB(cx,sv);
LEAVESUB(sv);
break;
case CXt_EVAL:
POPEVAL(cx);
break;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
POPLOOP(cx);
break;
case CXt_NULL:
break;
case CXt_FORMAT:
POPFORMAT(cx);
break;
}
cxstack_ix--;
}
PERL_UNUSED_VAR(optype);
}
void
Perl_qerror(pTHX_ SV *err)
{
dVAR;
PERL_ARGS_ASSERT_QERROR;
if (PL_in_eval) {
if (PL_in_eval & EVAL_KEEPERR) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
SvPV_nolen_const(err));
}
else
sv_catsv(ERRSV, err);
}
else if (PL_errors)
sv_catsv(PL_errors, err);
else
Perl_warn(aTHX_ "%"SVf, SVfARG(err));
if (PL_parser)
++PL_parser->error_count;
}
void
Perl_die_unwind(pTHX_ SV *msv)
{
dVAR;
SV *exceptsv = sv_mortalcopy(msv);
U8 in_eval = PL_in_eval;
PERL_ARGS_ASSERT_DIE_UNWIND;
if (in_eval) {
I32 cxix;
I32 gimme;
/*
* Historically, perl used to set ERRSV ($@) early in the die
* process and rely on it not getting clobbered during unwinding.
* That sucked, because it was liable to get clobbered, so the
* setting of ERRSV used to emit the exception from eval{} has
* been moved to much later, after unwinding (see just before
* JMPENV_JUMP below). However, some modules were relying on the
* early setting, by examining $@ during unwinding to use it as
* a flag indicating whether the current unwinding was caused by
* an exception. It was never a reliable flag for that purpose,
* being totally open to false positives even without actual
* clobberage, but was useful enough for production code to
* semantically rely on it.
*
* We'd like to have a proper introspective interface that
* explicitly describes the reason for whatever unwinding
* operations are currently in progress, so that those modules
* work reliably and $@ isn't further overloaded. But we don't
* have one yet. In its absence, as a stopgap measure, ERRSV is
* now *additionally* set here, before unwinding, to serve as the
* (unreliable) flag that it used to.
*
* This behaviour is temporary, and should be removed when a
* proper way to detect exceptional unwinding has been developed.
* As of 2010-12, the authors of modules relying on the hack
* are aware of the issue, because the modules failed on
* perls 5.13.{1..7} which had late setting of $@ without this
* early-setting hack.
*/
if (!(in_eval & EVAL_KEEPERR)) {
SvTEMP_off(exceptsv);
sv_setsv(ERRSV, exceptsv);
}
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
{
dounwind(-1);
POPSTACK;
}
if (cxix >= 0) {
I32 optype;
SV *namesv;
register PERL_CONTEXT *cx;
SV **newsp;
COP *oldcop;
JMPENV *restartjmpenv;
OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
STRLEN msglen;
const char* message = SvPVx_const(exceptsv, msglen);
PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
}
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
oldcop = cx->blk_oldcop;
restartjmpenv = cx->blk_eval.cur_top_env;
restartop = cx->blk_eval.retop;
if (gimme == G_SCALAR)
*++newsp = &PL_sv_undef;
PL_stack_sp = newsp;
LEAVE;
/* LEAVE could clobber PL_curcop (see save_re_context())
* XXX it might be better to find a way to avoid messing with
* PL_curcop in save_re_context() instead, but this is a more
* minimal fix --GSAR */
PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
const char* const msg = SvPVx_nolen_const(exceptsv);
(void)hv_store(GvHVn(PL_incgv),
SvPVX_const(namesv), SvCUR(namesv),
&PL_sv_undef, 0);
/* note that unlike pp_entereval, pp_require isn't
* supposed to trap errors. So now that we've popped the
* EVAL that pp_require pushed, and processed the error
* message, rethrow the error */
Perl_croak(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
if (in_eval & EVAL_KEEPERR) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
SvPV_nolen_const(exceptsv));
}
else {
sv_setsv(ERRSV, exceptsv);
}
PL_restartjmpenv = restartjmpenv;
PL_restartop = restartop;
JMPENV_JUMP(3);
/* NOTREACHED */
}
}
write_to_stderr(exceptsv);
my_failure_exit();
/* NOTREACHED */
}
PP(pp_xor)
{
dVAR; dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
RETSETNO;
}
/*
=for apidoc caller_cx
The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
returned C<PERL_CONTEXT> structure can be interrogated to find all the
information returned to Perl by C<caller>. Note that XSUBs don't get a
stack frame, so C<caller_cx(0, NULL)> will return information for the
immediately-surrounding Perl code.
This function skips over the automatic calls to C<&DB::sub> made on the
behalf of the debugger. If the stack frame requested was a sub called by
C<DB::sub>, the return value will be the frame for the call to
C<DB::sub>, since that has the correct line number/etc. for the call
site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
frame for the sub call itself.
=cut
*/
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
register I32 cxix = dopoptosub(cxstack_ix);
register const PERL_CONTEXT *cx;
register const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
top_si = top_si->si_prev;
ccstack = top_si->si_cxstack;
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0)
return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
count++;
if (!count--)
break;
cxix = dopoptosub_at(ccstack, cxix - 1);
}
cx = &ccstack[cxix];
if (dbcxp) *dbcxp = cx;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
return cx;
}
PP(pp_caller)
{
dVAR;
dSP;
register const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
I32 gimme;
const char *stashname;
I32 count = 0;
if (MAXARG)
count = POPi;
cx = caller_cx(count, &dbcx);
if (!cx) {
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
RETPUSHUNDEF;
}
RETURN;
}
stashname = CopSTASHPV(cx->blk_oldcop);
if (GIMME != G_ARRAY) {
EXTEND(SP, 1);
if (!stashname)
PUSHs(&PL_sv_undef);
else {
dTARGET;
sv_setpv(TARG, stashname);
PUSHs(TARG);
}
RETURN;
}
EXTEND(SP, 11);
if (!stashname)
PUSHs(&PL_sv_undef);
else
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(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
if (isGV(cvgv)) {
SV * const sv = newSV(0);
gv_efullname3(sv, cvgv, NULL);
mPUSHs(sv);
PUSHs(boolSV(CxHASARGS(cx)));
}
else {
PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
PUSHs(boolSV(CxHASARGS(cx)));
}
}
else {
PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
mPUSHi(0);
}
gimme = (I32)cx->blk_gimme;
if (gimme == G_VOID)
PUSHs(&PL_sv_undef);
else
PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
if (CxTYPE(cx) == CXt_EVAL) {
/* eval STRING */
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) {
mPUSHs(newSVsv(cx->blk_eval.old_namesv));
PUSHs(&PL_sv_yes);
}
/* eval BLOCK (try blocks have old_namesv == 0) */
else {
PUSHs(&PL_sv_undef);
PUSHs(&PL_sv_undef);
}
}
else {
PUSHs(&PL_sv_undef);
PUSHs(&PL_sv_undef);
}
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)
Perl_init_dbargs(aTHX);
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
av_extend(PL_dbargs, AvFILLp(ary) + off);
Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
}
/* XXX only hints propagated via op_private are currently
* visible (others are not easily accessible, since they
* use the global PL_hints) */
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
if (old_warnings == pWARN_NONE ||
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
else if (old_warnings == pWARN_ALL ||
(old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
/* 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", 0);
if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
mask = newSVsv(*bits_all);
}
else {
mask = newSVpvn(WARN_ALLstring, WARNsize) ;
}
}
else
mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
mPUSHs(mask);
}
PUSHs(cx->blk_oldcop->cop_hints_hash ?
sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
: &PL_sv_undef);
RETURN;
}
PP(pp_reset)
{
dVAR;
dSP;
const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
sv_reset(tmps, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
}
/* like pp_nextstate, but used instead when the debugger is active */
PP(pp_dbstate)
{
dVAR;
PL_curcop = (COP*)PL_op;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
PERL_ASYNC_CHECK();
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
register PERL_CONTEXT *cx;
const I32 gimme = G_ARRAY;
U8 hasargs;
GV * const gv = PL_DBgv;
register CV * const cv = GvCV(gv);
if (!cv)
DIE(aTHX_ "No DB::DB routine defined");
if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
/* don't do recursive DB::DB call */
return NORMAL;
ENTER;
SAVETMPS;
SAVEI32(PL_debug);
SAVESTACK_POS();
PL_debug = 0;
hasargs = 0;
SPAGAIN;
if (CvISXSUB(cv)) {
CvDEPTH(cv)++;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
CvDEPTH(cv)--;
FREETMPS;
LEAVE;
return NORMAL;
}
else {
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
RETURNOP(CvSTART(cv));
}
}
else
return NORMAL;
}
STATIC SV **
S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
{
PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
if (gimme == G_SCALAR) {
if (MARK < SP)
*++newsp = (SvFLAGS(*SP) & flags) ? *SP : sv_mortalcopy(*SP);
else {
/* MEXTEND() only updates MARK, so reuse it instead of newsp. */
MARK = newsp;
MEXTEND(MARK, 1);
*++MARK = &PL_sv_undef;
return MARK;
}
}
else if (gimme == G_ARRAY) {
/* in case LEAVE wipes old return values */
while (++MARK <= SP) {
if (SvFLAGS(*MARK) & flags)
*++newsp = *MARK;
else {
*++newsp = sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
}
/* When this function was called with MARK == newsp, we reach this
* point with SP == newsp. */
}
return newsp;
}
PP(pp_enter)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
ENTER_with_name("block");
SAVETMPS;
PUSHBLOCK(cx, CXt_BLOCK, SP);
RETURN;
}
PP(pp_leave)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
SV **newsp;
PMOP *newpm;
I32 gimme;
if (PL_op->op_flags & OPf_SPECIAL) {
cx = &cxstack[cxstack_ix];
cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
}
POPBLOCK(cx,newpm);
gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
TAINT_NOT;
SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE_with_name("block");
RETURN;
}
PP(pp_enteriter)
{
dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
void *itervar; /* location of the iteration variable */
U8 cxtype = CXt_LOOP_FOR;
ENTER_with_name("loop1");
SAVETMPS;
if (PL_op->op_targ) { /* "my" variable */
if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
SVs_PADSTALE, SVs_PADSTALE);
}
SAVEPADSVANDMORTALIZE(PL_op->op_targ);
#ifdef USE_ITHREADS
itervar = PL_comppad;
#else
itervar = &PAD_SVl(PL_op->op_targ);
#endif
}
else { /* symbol table variable */
GV * const gv = MUTABLE_GV(POPs);
SV** svp = &GvSV(gv);
save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
*svp = newSV(0);
itervar = (void *)gv;
}
if (PL_op->op_private & OPpITER_DEF)
cxtype |= CXp_FOR_DEF;
ENTER_with_name("loop2");
PUSHBLOCK(cx, cxtype, SP);
PUSHLOOP_FOR(cx, itervar, MARK);
if (PL_op->op_flags & OPf_STACKED) {
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
dPOPss;
SV * const right = maybe_ary;
SvGETMAGIC(sv);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(sv,right)) {
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.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->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 /* 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 { /* 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.state_u.ary.ix = cx->blk_oldsp + 1;
}
else {
cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
}
}
RETURN;
}
PP(pp_enterloop)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
ENTER_with_name("loop1");
SAVETMPS;
ENTER_with_name("loop2");
PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
PUSHLOOP_PLAIN(cx, SP);
RETURN;
}
PP(pp_leaveloop)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
SV **mark;
POPBLOCK(cx,newpm);
assert(CxTYPE_is_LOOP(cx));
mark = newsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
TAINT_NOT;
SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
PUTBACK;
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVE_with_name("loop2");
LEAVE_with_name("loop1");
return NORMAL;
}
STATIC void
S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
PERL_CONTEXT *cx, PMOP *newpm)
{
const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
if (gimme == G_SCALAR) {
if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
SV *sv;
if (MARK < SP) {
assert(MARK+1 == SP);
if ((SvPADTMP(TOPs) ||
(SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
== SVf_READONLY
) &&
!SvSMAGICAL(TOPs)) {
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
Perl_croak(aTHX_
"Can't return %s from lvalue subroutine",
SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
: "a readonly value" : "a temporary");
}
else { /* Can be a localized value
EXTEND_MORTAL(1); * subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *SP;
SvREFCNT_inc_void(*SP);
*++newsp = *SP;
}
}
else {
/* sub:lvalue{} will take us here. */
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
Perl_croak(aTHX_
/* diag_listed_as: Can't return %s from lvalue subroutine*/
"Can't return undef from lvalue subroutine"
);
}
}
else if (MARK < SP) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
}
else
*++newsp =
!SvTEMP(*SP)
? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
: *SP;
}
else {
EXTEND(newsp,1);
*++newsp = &PL_sv_undef;
}
if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
SvGETMAGIC(TOPs);
if (!SvOK(TOPs)) {
U8 deref_type;
if (cx->blk_sub.retop->op_type == OP_RV2SV)
deref_type = OPpDEREF_SV;
else if (cx->blk_sub.retop->op_type == OP_RV2AV)
deref_type = OPpDEREF_AV;
else {
assert(cx->blk_sub.retop->op_type == OP_RV2HV);
deref_type = OPpDEREF_HV;
}
vivify_ref(TOPs, deref_type);
}
}
}
else if (gimme == G_ARRAY) {
assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF));
if (ref || !CxLVAL(cx))
while (++MARK <= SP)
*++newsp =
SvTEMP(*MARK)
? *MARK
: ref && SvFLAGS(*MARK) & SVs_PADTMP
? sv_mortalcopy(*MARK)
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
else while (++MARK <= SP) {
if (*MARK != &PL_sv_undef
&& (SvPADTMP(*MARK)
|| (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
== SVf_READONLY
)
) {
SV *sv;
/* Might be flattened array after $#array = */
PUTBACK;
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
LEAVESUB(sv);
Perl_croak(aTHX_
"Can't return a %s from lvalue subroutine",
SvREADONLY(TOPs) ? "readonly value" : "temporary");
}
else
*++newsp =
SvTEMP(*MARK)
? *MARK
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
}
}
PL_stack_sp = newsp;
}
PP(pp_return)
{
dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
bool lval = FALSE;
bool gmagic = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
I32 optype = 0;
SV *namesv;
SV *sv;
OP *retop = NULL;
const I32 cxix = dopoptosub(cxstack_ix);
if (cxix < 0) {
if (CxMULTICALL(cxstack)) { /* In this case we must be in a
* sort block, which is a CXt_NULL
* not a CXt_SUB */
dounwind(0);
PL_stack_base[1] = *PL_stack_sp;
PL_stack_sp = PL_stack_base + 1;
return 0;
}
else
DIE(aTHX_ "Can't return outside a subroutine");
}
if (cxix < cxstack_ix)
dounwind(cxix);
if (CxMULTICALL(&cxstack[cxix])) {
gimme = cxstack[cxix].blk_gimme;
if (gimme == G_VOID)
PL_stack_sp = PL_stack_base;
else if (gimme == G_SCALAR) {
PL_stack_base[1] = *PL_stack_sp;
PL_stack_sp = PL_stack_base + 1;
}
return 0;
}
POPBLOCK(cx,newpm);
switch (CxTYPE(cx)) {
case CXt_SUB:
popsub2 = TRUE;
lval = !!CvLVALUE(cx->blk_sub.cv);
retop = cx->blk_sub.retop;
gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
break;
case CXt_EVAL:
if (!(PL_in_eval & EVAL_KEEPERR))
clear_errsv = TRUE;
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
if (CxTRYBLOCK(cx))
break;
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
SvPVX_const(namesv), SvCUR(namesv),
G_DISCARD);
DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
}
break;
case CXt_FORMAT:
POPFORMAT(cx);
retop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: return");
}
TAINT_NOT;
if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
else {
if (gimme == G_SCALAR) {
if (MARK < SP) {
if (popsub2) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
}
else {
sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
FREETMPS;
*++newsp = sv_mortalcopy(sv);
SvREFCNT_dec(sv);
if (gmagic) SvGETMAGIC(sv);
}
}
else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
*++newsp = *SP;
if (gmagic) SvGETMAGIC(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
}
else
*++newsp = &PL_sv_undef;
}
else if (gimme == G_ARRAY) {
while (++MARK <= SP) {
*++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
? *MARK : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
}
PL_stack_sp = newsp;
}
LEAVE;
/* Stack values are safe: */
if (popsub2) {
cxstack_ix--;
POPSUB(cx,sv); /* release CV and @_ ... */
}
else
sv = NULL;
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
if (clear_errsv) {
CLEAR_ERRSV();
}
return retop;
}
/* This duplicates parts of pp_leavesub, so that it can share code with
* pp_return */
PP(pp_leavesublv)
{
dVAR; dSP;
SV **newsp;
PMOP *newpm;
I32 gimme;
register PERL_CONTEXT *cx;
SV *sv;
if (CxMULTICALL(&cxstack[cxstack_ix]))
return 0;
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
assert(CvLVALUE(cx->blk_sub.cv));
TAINT_NOT;
S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
LEAVE;
cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
return cx->blk_sub.retop;
}
PP(pp_last)
{
dVAR; dSP;
I32 cxix;
register PERL_CONTEXT *cx;
I32 pop2 = 0;
I32 gimme;
I32 optype;
OP *nextop = NULL;
SV **newsp;
PMOP *newpm;
SV **mark;
SV *sv = NULL;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't \"last\" outside a loop block");
}
else {
cxix = dopoptolabel(cPVOP->op_pv);
if (cxix < 0)
DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
}
if (cxix < cxstack_ix)
dounwind(cxix);
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
mark = newsp;
switch (CxTYPE(cx)) {
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;
case CXt_SUB:
pop2 = CXt_SUB;
nextop = cx->blk_sub.retop;
break;
case CXt_EVAL:
POPEVAL(cx);
nextop = cx->blk_eval.retop;
break;
case CXt_FORMAT:
POPFORMAT(cx);
nextop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: last");
}
TAINT_NOT;
SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
pop2 == CXt_SUB ? SVs_TEMP : 0);
PUTBACK;
LEAVE;
cxstack_ix--;
/* Stack values are safe: */
switch (pop2) {
case CXt_LOOP_LAZYIV:
case CXt_LOOP_PLAIN:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
POPLOOP(cx); /* release loop vars ... */
LEAVE;
break;
case CXt_SUB:
POPSUB(cx,sv); /* release CV and @_ ... */
break;
}
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
PERL_UNUSED_VAR(optype);
PERL_UNUSED_VAR(gimme);
return nextop;
}
PP(pp_next)
{
dVAR;
I32 cxix;
register PERL_CONTEXT *cx;
I32 inner;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't \"next\" outside a loop block");
}
else {
cxix = dopoptolabel(cPVOP->op_pv);
if (cxix < 0)
DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
}
if (cxix < cxstack_ix)
dounwind(cxix);
/* clear off anything above the scope we're re-entering, but
* save the rest until after a possible continue block */
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_loop.my_op->op_nextop;
}
PP(pp_redo)
{
dVAR;
I32 cxix;
register PERL_CONTEXT *cx;
I32 oldsave;
OP* redo_op;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't \"redo\" outside a loop block");
}
else {
cxix = dopoptolabel(cPVOP->op_pv);
if (cxix < 0)
DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
}
if (cxix < cxstack_ix)
dounwind(cxix);
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++;
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
redo_op = redo_op->op_next;
}
TOPBLOCK(cx);
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
FREETMPS;
PL_curcop = cx->blk_oldcop;
return redo_op;
}
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 ||
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVELOOP ||
o->op_type == OP_LEAVESUB ||
o->op_type == OP_LEAVETRY)
{
*ops++ = cUNOPo->op_first;
if (ops >= oplimit)
Perl_croak(aTHX_ too_deep);
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
OP *kid;
/* 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) {
const char *kid_label = CopLABEL(kCOP);
if (kid_label && strEQ(kid_label, label))
return kid;
}
}
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == PL_lastgotoprobe)
continue;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
if (ops == opstack)
*ops++ = kid;
else if (ops[-1]->op_type == OP_NEXTSTATE ||
ops[-1]->op_type == OP_DBSTATE)
ops[-1] = kid;
else
*ops++ = kid;
}
if ((o = dofindlabel(kid, label, ops, oplimit)))
return o;
}
}
*ops = 0;
return 0;
}
PP(pp_goto)
{
dVAR; dSP;
OP *retop = NULL;
I32 ix;
register PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
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 (PL_op->op_flags & OPf_STACKED) {
SV * const sv = POPs;
/* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
I32 cxix;
register PERL_CONTEXT *cx;
CV *cv = MUTABLE_CV(SvRV(sv));
SV** mark;
I32 items = 0;
I32 oldsave;
bool reified = 0;
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
const GV * const gv = CvGV(cv);
if (gv) {
GV *autogv;
SV *tmpstr;
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
goto retry;
autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
GvNAMELEN(gv), FALSE);
if (autogv && (cv = GvCV(autogv)))
goto retry;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
}
DIE(aTHX_ "Goto undefined subroutine");
}
/* First do some returnish stuff. */
SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't goto subroutine outside a subroutine");
if (cxix < cxstack_ix)
dounwind(cxix);
TOPBLOCK(cx);
SPAGAIN;
/* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
if (CxTYPE(cx) == CXt_EVAL) {
if (CxREALEVAL(cx))
DIE(aTHX_ "Can't goto subroutine from an eval-string");
else
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
else if (CxMULTICALL(cx))
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
items = AvFILLp(av) + 1;
EXTEND(SP, items+1); /* @_ could have been extended. */
Copy(AvARRAY(av), SP + 1, items, SV*);
SvREFCNT_dec(GvAV(PL_defgv));
GvAV(PL_defgv) = cx->blk_sub.savearray;
CLEAR_ARGARRAY(av);
/* abandon @_ if it got reified */
if (AvREAL(av)) {
reified = 1;
SvREFCNT_dec(av);
av = newAV();
av_extend(av, items-1);
AvREIFY_only(av);
PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
}
}
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. */
Copy(AvARRAY(av), SP + 1, items, SV*);
}
mark = SP;
SP += items;
if (CxTYPE(cx) == CXt_SUB &&
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
SvREFCNT_dec(cx->blk_sub.cv);
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
/* Now do some callish stuff. */
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
OP* const retop = cx->blk_sub.retop;
SV **newsp __attribute__unused__;
I32 gimme __attribute__unused__;
if (reified) {
I32 index;
for (index=0; index<items; index++)
sv_2mortal(SP[-index]);
}
/* 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* const padlist = CvPADLIST(cv);
if (CxTYPE(cx) == CXt_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.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
SvREFCNT_inc_simple_void_NN(cv);
else {
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 (CxHASARGS(cx))
{
AV *const av = MUTABLE_AV(PAD_SVl(0));
cx->blk_sub.savearray = GvAV(PL_defgv);
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) {
SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
AvARRAY(av) = ary;
}
if (items >= AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items+1,SV*);
AvALLOC(av) = ary;
AvARRAY(av) = ary;
}
}
++mark;
Copy(mark,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
assert(!AvREAL(av));
if (reified) {
/* transfer 'ownership' of refcnts to new @_ */
AvREAL_on(av);
AvREIFY_off(av);
}
while (items--) {
if (*mark)
SvTEMP_off(*mark);
mark++;
}
}
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
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));
}
}
else {
label = SvPV_nolen_const(sv);
if (!(do_dump || *label))
DIE(aTHX_ must_have_label);
}
}
else if (PL_op->op_flags & OPf_SPECIAL) {
if (! do_dump)
DIE(aTHX_ must_have_label);
}
else
label = cPVOP->op_pv;
PERL_ASYNC_CHECK();
if (label && *label) {
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
PERL_CONTEXT *last_eval_cx = NULL;
/* find label */
PL_lastgotoprobe = NULL;
*enterops = 0;
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
switch (CxTYPE(cx)) {
case CXt_EVAL:
leaving_eval = TRUE;
if (!CxTRYBLOCK(cx)) {
gotoprobe = (last_eval_cx ?
last_eval_cx->blk_eval.old_eval_root :
PL_eval_root);
last_eval_cx = cx;
break;
}
/* else fall through */
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:
continue;
case CXt_BLOCK:
if (ix) {
gotoprobe = cx->blk_oldcop->op_sibling;
in_block = TRUE;
} else
gotoprobe = PL_main_root;
break;
case CXt_SUB:
if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
gotoprobe = CvROOT(cx->blk_sub.cv);
break;
}
/* FALL THROUGH */
case CXt_FORMAT:
case CXt_NULL:
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
default:
if (ix)
DIE(aTHX_ "panic: goto");
gotoprobe = PL_main_root;
break;
}
if (gotoprobe) {
retop = dofindlabel(gotoprobe, label,
enterops, enterops + GOTO_DEPTH);
if (retop)
break;
if (gotoprobe->op_sibling &&
gotoprobe->op_sibling->op_type == OP_UNSTACK &&
gotoprobe->op_sibling->op_sibling) {
retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
label, enterops, enterops + GOTO_DEPTH);
if (retop)
break;
}
}
PL_lastgotoprobe = gotoprobe;
}
if (!retop)
DIE(aTHX_ "Can't find label %s", label);
/* if we're leaving an eval, check before we pop any frames
that we're not going to punt, otherwise the error
won't be caught */
if (leaving_eval && *enterops && enterops[1]) {
I32 i;
for (i = 1; enterops[i]; i++)
if (enterops[i]->op_type == OP_ENTERITER)
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
}
if (*enterops && enterops[1]) {
I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
if (enterops[i])
deprecate("\"goto\" to jump into a construct");
}
/* pop unwanted frames */
if (ix < cxstack_ix) {
I32 oldsave;
if (ix < 0)
ix = 0;
dounwind(ix);
TOPBLOCK(cx);
oldsave = PL_scopestack[PL_scopestack_ix];
LEAVE_SCOPE(oldsave);
}
/* push wanted frames */
if (*enterops && enterops[1]) {
OP * const oldop = PL_op;
ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
/* Eventually we may want to stack the needed arguments
* for each op. For now, we punt on the hard ones. */
if (PL_op->op_type == OP_ENTERITER)
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
PL_op->op_ppaddr(aTHX);
}
PL_op = oldop;
}
}
if (do_dump) {
#ifdef VMS
if (!retop) retop = PL_main_start;
#endif
PL_restartop = retop;
PL_do_undump = TRUE;
my_unexec();
PL_restartop = 0; /* hmm, must be GNU unexec().. */
PL_do_undump = FALSE;
}
RETURNOP(retop);
}
PP(pp_exit)
{
dVAR;
dSP;
I32 anum;
if (MAXARG < 1)
anum = 0;
else {
anum = SvIVx(POPs);
#ifdef VMS
if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
anum = 0;
VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
#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;
}
/* Eval. */
STATIC void
S_save_lines(pTHX_ AV *array, SV *sv)
{
const char *s = SvPVX_const(sv);
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);
t = (const char *)memchr(s, '\n', send - s);
if (t)
t++;
else
t = send;
sv_setpvn(tmpstr, s, t - s);
av_store(array, line++, tmpstr);
s = t;
}
}
/*
=for apidoc docatch
Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
0 is used as continue inside eval,
3 is used for a die caught by an inner eval - continue inner loop
See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
establish a local jmpenv to handle exception traps.
=cut
*/
STATIC OP *
S_docatch(pTHX_ OP *o)
{
dVAR;
int ret;
OP * const oldop = PL_op;
dJMPENV;
#ifdef DEBUGGING
assert(CATCH_GET == TRUE);
#endif
PL_op = o;
JMPENV_PUSH(ret);
switch (ret) {
case 0:
assert(cxstack_ix >= 0);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
redo_body:
CALLRUNOPS(aTHX);
break;
case 3:
/* die caught by an inner eval - continue inner loop */
if (PL_restartop && PL_restartjmpenv == PL_top_env) {
PL_restartjmpenv = NULL;
PL_op = PL_restartop;
PL_restartop = 0;
goto redo_body;
}
/* FALL THROUGH */
default:
JMPENV_POP;
PL_op = oldop;
JMPENV_JUMP(ret);
/* NOTREACHED */
}
JMPENV_POP;
PL_op = oldop;
return NULL;
}
/* James Bond: Do you expect me to talk?
Auric Goldfinger: No, Mr. Bond. I expect you to die.
This code is an ugly hack, doesn't work with lexicals in subroutines that are
called more than once, and is only used by regcomp.c, for (?{}) blocks.
Currently it is not used outside the core code. Best if it stays that way.
Hence it's now deprecated, and will be removed.
*/
OP *
Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
/* sv Text to convert to OP tree. */
/* startop op_free() this to undo. */
/* code Short string id of the caller. */
{
PERL_ARGS_ASSERT_SV_COMPILE_2OP;
return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
}
/* Don't use this. It will go away without warning once the regexp engine is
refactored not to use it. */
OP *
Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
PAD **padp)
{
dVAR; dSP; /* Make POPBLOCK work. */
PERL_CONTEXT *cx;
SV **newsp;
I32 gimme = G_VOID;
I32 optype;
OP dummy;
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
int runtime;
CV* runcv = NULL; /* initialise to avoid compiler warnings */
STRLEN len;
bool need_catch;
PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
ENTER_with_name("eval");
lex_start(sv, NULL, LEX_START_SAME_FILTER);
SAVETMPS;
/* switch to eval mode */
if (IN_PERL_COMPILETIME) {
SAVECOPSTASH_FREE(&PL_compiling);
CopSTASH_set(&PL_compiling, PL_curstash);
}
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
SV * const sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
code, (unsigned long)++PL_evalseq,
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
tmpbuf = SvPVX(sv);
len = SvCUR(sv);
}
else
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);
CopLINE_set(&PL_compiling, 1);
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
deleting the eval's FILEGV from the stash before gv_check() runs
(i.e. before run-time proper). To work around the coredump that
ensues, we always turn GvMULTI_on for any globals that were
introduced within evals. See force_ident(). GSAR 96-10-12 */
safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
SAVEHINTS();
#ifdef OP_IN_REGISTER
PL_opsave = op;
#else
SAVEVPTR(PL_op);
#endif
/* we get here either during compilation, or via pp_regcomp at runtime */
runtime = IN_PERL_RUNTIME;
if (runtime)
{
runcv = find_runcv(NULL);
/* At run time, we have to fetch the hints from PL_curcop. */
PL_hints = PL_curcop->cop_hints;
if (PL_hints & HINT_LOCALIZE_HH) {
/* SAVEHINTS created a new HV in PL_hintgv, which we
need to GC */
SvREFCNT_dec(GvHV(PL_hintgv));
GvHV(PL_hintgv) =
refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
}
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
cophh_free(CopHINTHASH_get(&PL_compiling));
/* XXX Does this need to avoid copying a label? */
PL_compiling.cop_hints_hash
= cophh_copy(PL_curcop->cop_hints_hash);
}
PL_op = &dummy;
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);
need_catch = CATCH_GET;
CATCH_SET(TRUE);
if (runtime)
(void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
else
(void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
CATCH_SET(need_catch);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
(*startop)->op_type = OP_NULL;
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
/* XXX DAPM do this properly one year */
*padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
LEAVE_with_name("eval");
if (IN_PERL_COMPILETIME)
CopHINTS_set(&PL_compiling, PL_hints);
#ifdef OP_IN_REGISTER
op = PL_opsave;
#endif
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
return PL_eval_start;
}
/*
=for apidoc find_runcv
Locate the CV corresponding to the currently executing sub or eval.
If db_seqp is non_null, skip CVs that are in the DB package and populate
*db_seqp with the cop sequence number at the point that the DB:: code was
entered. (allows debuggers to eval in the scope of the breakpoint rather
than in the scope of the debugger itself).
=cut
*/
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
dVAR;
PERL_SI *si;
if (db_seqp)
*db_seqp = PL_curcop->cop_seq;
for (si = PL_curstackinfo; si; si = si->si_prev) {
I32 ix;
for (ix = si->si_cxix; ix >= 0; ix--) {
const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
CV * const cv = cx->blk_sub.cv;
/* skip DB:: code */
if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
*db_seqp = cx->blk_oldcop->cop_seq;
continue;
}
return cv;
}
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
return PL_compcv;
}
}
return PL_main_cv;
}
/* Run yyparse() in a setjmp wrapper. Returns:
* 0: yyparse() successful
* 1: yyparse() failed
* 3: yyparse() died
*/
STATIC int
S_try_yyparse(pTHX_ int gramtype)
{
int ret;
dJMPENV;
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
JMPENV_PUSH(ret);
switch (ret) {
case 0:
ret = yyparse(gramtype) ? 1 : 0;
break;
case 3:
break;
default:
JMPENV_POP;
JMPENV_JUMP(ret);
/* NOTREACHED */
}
JMPENV_POP;
return ret;
}
/* Compile a require/do, an eval '', or a /(?{...})/.
* 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 bool
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dVAR; dSP;
OP * const saveop = PL_op;
bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
int yystatus;
PL_in_eval = (in_require
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
: EVAL_INEVAL);
PUSHMARK(SP);
SAVESPTR(PL_compcv);
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) = 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 */
if (!PL_madskills)
SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
if (CopSTASH_ne(PL_curcop, PL_curstash)) {
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);
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 = NULL;
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
CLEAR_ERRSV();
CALL_BLOCK_HOOKS(bhk_eval, saveop);
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
* so honour CATCH_GET and trap it here if necessary */
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = NULL;
I32 optype; /* Used by POPEVAL. */
SV *namesv = NULL;
const char *msg;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
/* note that if yystatus == 3, then the EVAL CX block has already
* been popped, and various vars restored */
PL_op = saveop;
if (yystatus != 3) {
if (PL_eval_root) {
op_free(PL_eval_root);
PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
if (!startop) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
}
}
if (yystatus != 3)
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
msg = SvPVx_nolen_const(ERRSV);
if (in_require) {
if (!cx) {
/* If cx is still NULL, it means that we didn't go in the
* POPEVAL branch. */
cx = &cxstack[cxstack_ix];
assert(CxTYPE(cx) == CXt_EVAL);
namesv = cx->blk_eval.old_namesv;
}
(void)hv_store(GvHVn(PL_incgv),
SvPVX_const(namesv), SvCUR(namesv),
&PL_sv_undef, 0);
Perl_croak(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
else if (startop) {
if (yystatus != 3) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
}
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
else {
if (!*msg) {
sv_setpvs(ERRSV, "Compilation error");
}
}
PUSHs(&PL_sv_undef);
PUTBACK;
return FALSE;
}
CopLINE_set(&PL_compiling, 0);
if (startop) {
*startop = PL_eval_root;
} else
SAVEFREEOP(PL_eval_root);
/* Set the context for this new optree.
* Propagate the context from the eval(). */
if ((gimme & G_WANT) == G_VOID)
scalarvoid(PL_eval_root);
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 && saveop->op_type == OP_REQUIRE) {
CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
PUTBACK;
call_sv(MUTABLE_SV(cv), G_DISCARD);
}
}
if (PL_unitcheckav) {
OP *es = PL_eval_start;
call_list(PL_scopestack_ix, PL_unitcheckav);
PL_eval_start = es;
}
/* 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_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
PUTBACK;
return TRUE;
}
STATIC PerlIO *
S_check_type_and_open(pTHX_ SV *name)
{
Stat_t st;
const char *p = SvPV_nolen_const(name);
const int st_rc = PerlLIO_stat(p, &st);
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
#else
return PerlIO_open(p, PERL_SCRIPT_MODE);
#endif
}
#ifndef PERL_DISABLE_PMC
STATIC PerlIO *
S_doopen_pm(pTHX_ SV *name)
{
STRLEN namelen;
const char *p = SvPV_const(name, namelen);
PERL_ARGS_ASSERT_DOOPEN_PM;
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
SV *const pmcsv = sv_newmortal();
Stat_t pmcstat;
SvSetSV_nosteal(pmcsv,name);
sv_catpvn(pmcsv, "c", 1);
if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
return check_type_and_open(pmcsv);
}
return check_type_and_open(name);
}
#else
# define doopen_pm(name) check_type_and_open(name)
#endif /* !PERL_DISABLE_PMC */
PP(pp_require)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
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;
int filter_has_file = 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) {
sv = sv_2mortal(new_version(sv));
if (!sv_derived_from(PL_patchlevel, "version"))
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 )
DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
SVfARG(sv_2mortal(vnormal(sv))),
SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
);
}
else {
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(sv_2mortal(vnormal(req))),
SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
);
}
else { /* probably 'use 5.10' or 'use 5.8' */
SV *hintsv;
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.0",
(int)first, (int)second);
upg_version(hintsv, TRUE);
DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
"--this is only %"SVf", stopped",
SVfARG(sv_2mortal(vnormal(req))),
SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
);
}
}
}
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),
unixname, unixlen, 0);
if ( svp ) {
if (*svp != &PL_sv_undef)
RETPUSHYES;
else
DIE(aTHX_ "Attempt to reload %s aborted.\n"
"Compilation failed in require", unixname);
}
}
/* prepare to compile file */
if (path_is_absolute(name)) {
/* At this point, name is SvPVX(sv) */
tryname = name;
tryrsfp = doopen_pm(sv);
}
if (!tryrsfp) {
AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
if (vms_unixname)
#endif
{
namesv = newSV_type(SVt_PV);
for (i = 0; i <= AvFILL(ar); i++) {
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(MUTABLE_AV(SvRV(loader)), 0, TRUE);
}
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
PTR2UV(SvRV(dirsv)), name);
tryname = SvPVX_const(namesv);
tryrsfp = NULL;
ENTER_with_name("call_INC");
SAVETMPS;
EXTEND(SP, 2);
PUSHMARK(SP);
PUSHs(dirsv);
PUSHs(sv);
PUTBACK;
if (sv_isobject(loader))
count = call_method("INC", G_ARRAY);
else
count = call_sv(loader, G_ARRAY);
SPAGAIN;
if (count > 0) {
int i = 0;
SV *arg;
SP -= count - 1;
arg = SP[i++];
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 (isGV_with_GP(arg)) {
IO * const io = GvIO((const GV *)arg);
++filter_has_file;
if (io) {
tryrsfp = IoIFP(io);
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
PerlIO_close(IoOFP(io));
}
IoIFP(io) = NULL;
IoOFP(io) = NULL;
}
if (i < count) {
arg = SP[i++];
}
}
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
filter_sub = arg;
SvREFCNT_inc_simple_void_NN(filter_sub);
if (i < count) {
filter_state = SP[i];
SvREFCNT_inc_simple_void(filter_state);
}
}
if (!tryrsfp && (filter_cache || filter_sub)) {
tryrsfp = PerlIO_open(BIT_BUCKET,
PERL_SCRIPT_MODE);
}
SP--;
}
PUTBACK;
FREETMPS;
LEAVE_with_name("call_INC");
/* Adjust file name if the hook has set an %INC entry.
This needs to happen after the FREETMPS above. */
svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
if (svp)
tryname = SvPV_nolen_const(*svp);
if (tryrsfp) {
hook_sv = dirsv;
break;
}
filter_has_file = 0;
if (filter_cache) {
SvREFCNT_dec(filter_cache);
filter_cache = NULL;
}
if (filter_state) {
SvREFCNT_dec(filter_state);
filter_state = NULL;
}
if (filter_sub) {
SvREFCNT_dec(filter_sub);
filter_sub = NULL;
}
}
else {
if (!path_is_absolute(name)
) {
const char *dir;
STRLEN dirlen;
if (SvOK(dirsv)) {
dir = SvPV_const(dirsv, dirlen);
} else {
dir = "";
dirlen = 0;
}
#ifdef VMS
char *unixdir;
if ((unixdir = tounixpath(dir, NULL)) == NULL)
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
#else
# ifdef __SYMBIAN32__
if (PL_origfilename[0] &&
PL_origfilename[1] == ':' &&
!(dir[0] && dir[1] == ':'))
Perl_sv_setpvf(aTHX_ namesv,
"%c:%s\\%s",
PL_origfilename[0],
dir, name);
else
Perl_sv_setpvf(aTHX_ namesv,
"%s\\%s",
dir, name);
# 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);
SvPOK_on(namesv);
}
# endif
#endif
TAINT_PROPER("require");
tryname = SvPVX_const(namesv);
tryrsfp = doopen_pm(namesv);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/') {
++tryname;
while (*++tryname == '/');
}
break;
}
else if (errno == EMFILE)
/* no point in trying other paths if out of handles */
break;
}
}
}
}
}
sv_2mortal(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
if(errno == EMFILE) {
/* diag_listed_as: Can't locate %s */
DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
} else {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
I32 i;
SV *const inc = newSVpvs_flags("", SVs_TEMP);
for (i = 0; i <= AvFILL(ar); i++) {
sv_catpvs(inc, " ");
sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
/* diag_listed_as: Can't locate %s */
DIE(aTHX_
"Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
name,
(memEQ(name + len - 2, ".h", 3)
? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
(memEQ(name + len - 3, ".ph", 4)
? " (did you run h2ph?)" : ""),
inc
);
}
}
DIE(aTHX_ "Can't locate %s", name);
}
RETPUSHUNDEF;
}
else
SETERRNO(0, SS_NORMAL);
/* Assume success here to prevent recursive requirement. */
/* 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),
unixname, unixlen, newSVpv(tryname,0),0);
} else {
SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
if (!svp)
(void)hv_store(GvHVn(PL_incgv),
unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
ENTER_with_name("eval");
SAVETMPS;
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tryname);
lex_start(NULL, tryrsfp, 0);
SAVEHINTS();
PL_hints = 0;
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
PL_compiling.cop_warnings = pWARN_STD ;
if (filter_sub || filter_cache) {
/* We can use the SvPV of the filter PVIO itself as our cache, rather
than hanging another SV from it. In turn, filter_add() optionally
takes the SV to use as the filter (or creates a new SV if passed
NULL), so simply pass in whatever value filter_cache has. */
SV * const datasv = filter_add(S_run_user_filter, filter_cache);
IoLINES(datasv) = filter_has_file;
IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
}
/* switch to eval mode */
PUSHBLOCK(cx, CXt_EVAL, SP);
PUSHEVAL(cx, name);
cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 0);
PUTBACK;
/* Store and reset encoding. */
encoding = PL_encoding;
PL_encoding = NULL;
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(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
RETURN;
}
PP(pp_entereval)
{
dVAR; dSP;
register PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
const U32 was = PL_breakable_sub_gen;
char tbuf[TYPE_DIGITS(long) + 12];
bool saved_delete = FALSE;
char *tmpbuf = tbuf;
STRLEN len;
CV* runcv;
U32 seq;
HV *saved_hh = NULL;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
sv = POPs;
if (!SvPOK(sv)) {
/* make sure we've got a plain PV (no overload etc) before testing
* for taint. Making a copy here is probably overkill, but better
* safe than sorry */
STRLEN len;
const char * const p = SvPV_const(sv, len);
sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
}
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
ENTER_with_name("eval");
lex_start(sv, NULL, LEX_START_SAME_FILTER);
SAVETMPS;
/* switch to eval mode */
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
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(temp_sv);
len = SvCUR(temp_sv);
}
else
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);
CopLINE_set(&PL_compiling, 1);
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
deleting the eval's FILEGV from the stash before gv_check() runs
(i.e. before run-time proper). To work around the coredump that
ensues, we always turn GvMULTI_on for any globals that were
introduced within evals. See force_ident(). GSAR 96-10-12 */
SAVEHINTS();
PL_hints = PL_op->op_targ;
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;
}
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
cophh_free(CopHINTHASH_get(&PL_compiling));
if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
/* The label, if present, is the first entry on the chain. So rather
than writing a blank label in front of it (which involves an
allocation), just use the next entry in the chain. */
PL_compiling.cop_hints_hash
= cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
/* Check the assumption that this removed the label. */
assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
}
else
PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
/* special case: an eval '' executed within the DB package gets lexically
* placed in the first non-DB CV rather than the current CV - this
* allows the debugger to execute code, find lexicals etc, in the
* scope of the code being debugged. Passing &seq gets find_runcv
* to do the dirty work for us */
runcv = find_runcv(&seq);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
PUSHEVAL(cx, 0);
cx->blk_eval.retop = PL_op->op_next;
/* prepare to compile string */
if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
else {
char *const safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
saved_delete = TRUE;
}
PUTBACK;
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 if (!saved_delete) {
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 earlier 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 if (!saved_delete) {
(void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
}
return PL_op->op_next;
}
}
PP(pp_leaveeval)
{
dVAR; dSP;
SV **newsp;
PMOP *newpm;
I32 gimme;
register PERL_CONTEXT *cx;
OP *retop;
const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV *namesv;
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
TAINT_NOT;
SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
gimme, SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
#ifdef DEBUGGING
assert(CvDEPTH(PL_compcv) == 1);
#endif
CvDEPTH(PL_compcv) = 0;
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
{
/* Unassume the success we assumed earlier. */
(void)hv_delete(GvHVn(PL_incgv),
SvPVX_const(namesv), SvCUR(namesv),
G_DISCARD);
retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
SVfARG(namesv));
/* die_unwind() did LEAVE, or we won't be here */
}