/* pp_ctl.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
* And whither then? I cannot say.
*/
+/* 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))
-static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
-
PP(pp_wantarray)
{
+ dVAR;
dSP;
I32 cxix;
EXTEND(SP, 1);
}
}
-PP(pp_regcmaybe)
-{
- return NORMAL;
-}
-
PP(pp_regcreset)
{
+ dVAR;
/* XXXX Should store the old value to allow for tie/overload - and
restore in regcomp, where marked with XXXX. */
PL_reginterp_cnt = 0;
PP(pp_regcomp)
{
+ dVAR;
dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
- register char *t;
SV *tmpstr;
- STRLEN len;
- MAGIC *mg = Null(MAGIC*);
-
- tmpstr = POPs;
+ MAGIC *mg = NULL;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
- if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
- RETURN;
+ if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
+ if (PL_op->op_flags & OPf_STACKED) {
+ dMARK;
+ SP = MARK;
+ }
+ else
+ (void)POPs;
+ RETURN;
+ }
#endif
+ if (PL_op->op_flags & OPf_STACKED) {
+ /* multiple args; concatentate them */
+ dMARK; dORIGMARK;
+ tmpstr = PAD_SV(ARGTARG);
+ sv_setpvn(tmpstr, "", 0);
+ while (++MARK <= SP) {
+ if (PL_amagic_generation) {
+ SV *sv;
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
+ (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+ {
+ sv_setsv(tmpstr, sv);
+ continue;
+ }
+ }
+ sv_catsv(tmpstr, *MARK);
+ }
+ SvSETMAGIC(tmpstr);
+ SP = ORIGMARK;
+ }
+ else
+ tmpstr = POPs;
if (SvROK(tmpstr)) {
- SV *sv = SvRV(tmpstr);
+ SV * const sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
mg = mg_find(sv, PERL_MAGIC_qr);
}
if (mg) {
- regexp *re = (regexp *)mg->mg_obj;
+ regexp * const re = (regexp *)mg->mg_obj;
ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, ReREFCNT_inc(re));
}
else {
- t = SvPV(tmpstr, len);
+ STRLEN len;
+ const char *t = SvPV_const(tmpstr, len);
+ regexp * const re = PM_GETRE(pm);
/* Check against the last compiled regexp. */
- if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
- PM_GETRE(pm)->prelen != (I32)len ||
- memNE(PM_GETRE(pm)->precomp, t, len))
+ if (!re || !re->precomp || re->prelen != (I32)len ||
+ memNE(re->precomp, t, len))
{
- if (PM_GETRE(pm)) {
- ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
+ if (re) {
+ ReREFCNT_dec(re);
+ PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
if (pm->op_pmdynflags & PMdf_UTF8)
t = (char*)bytes_to_utf8((U8*)t, &len);
}
- PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
+ PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm));
if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
Safefree(t);
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
PP(pp_substcont)
{
+ dVAR;
dSP;
- register PMOP *pm = (PMOP*) cLOGOP->op_other;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
- register SV *dstr = cx->sb_dstr;
+ 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 *rx = cx->sb_rx;
- SV *nsv = Nullsv;
+ register REGEXP * const rx = cx->sb_rx;
+ SV *nsv = NULL;
REGEXP *old = PM_GETRE(pm);
if(old != rx) {
- if(old)
+ if(old)
ReREFCNT_dec(old);
- PM_SETRE(pm,rx);
+ PM_SETRE(pm,ReREFCNT_inc(rx));
}
rxres_restore(&cx->sb_rxres, rx);
- RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
+ RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
if (cx->sb_iters++) {
- I32 saviters = cx->sb_iters;
+ const I32 saviters = cx->sb_iters;
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
cx->sb_rxtainted |= 2;
sv_catsv(dstr, POPs);
+ FREETMPS; /* Prevent excess tmp stack */
/* Are we done */
- if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
+ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
s == m, 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;
+ SV * const targ = cx->sb_targ;
assert(cx->sb_strend >= s);
if(cx->sb_strend > s) {
}
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(targ)) {
sv_force_normal_flags(targ, SV_COW_DROP_PV);
} else
#endif
{
- (void)SvOOK_off(targ);
- if (SvLEN(targ))
- Safefree(SvPVX(targ));
+ SvPV_free(targ);
}
- SvPVX(targ) = SvPVX(dstr);
+ SvPV_set(targ, SvPVX(dstr));
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
if (DO_UTF8(dstr))
SvUTF8_on(targ);
- SvPVX(dstr) = 0;
- sv_free(dstr);
+ SvPV_set(dstr, NULL);
TAINT_IF(cx->sb_rxtainted & 1);
PUSHs(sv_2mortal(newSViv(saviters - 1)));
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
- ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
}
cx->sb_m = m = rx->startp[0] + orig;
if (m > s) {
- if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
+ if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
else
sv_catpvn(dstr, s, m-s);
}
cx->sb_s = rx->endp[0] + orig;
{ /* Update the pos() information. */
- SV *sv = cx->sb_targ;
+ SV * const sv = cx->sb_targ;
MAGIC *mg;
I32 i;
if (SvTYPE(sv) < SVt_PVMG)
- (void)SvUPGRADE(sv, SVt_PVMG);
+ SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
- sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
- mg = mg_find(sv, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(lsv))
+ sv_force_normal_flags(sv, 0);
+#endif
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
+ NULL, 0);
}
i = m - orig;
if (DO_UTF8(sv))
mg->mg_len = i;
}
if (old != rx)
- ReREFCNT_inc(rx);
+ (void)ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
{
UV *p = (UV*)*rsp;
U32 i;
+ PERL_UNUSED_CONTEXT;
if (!p || p[1] < rx->nparens) {
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
i = 7 + rx->nparens * 2;
#else
i = 6 + rx->nparens * 2;
#endif
if (!p)
- New(501, p, i, UV);
+ Newx(p, i, UV);
else
Renew(p, i, UV);
*rsp = (void*)p;
}
- *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
+ *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
RX_MATCH_COPIED_off(rx);
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
*p++ = PTR2UV(rx->saved_copy);
- rx->saved_copy = Nullsv;
+ rx->saved_copy = NULL;
#endif
*p++ = rx->nparens;
{
UV *p = (UV*)*rsp;
U32 i;
+ PERL_UNUSED_CONTEXT;
RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (rx->saved_copy)
SvREFCNT_dec (rx->saved_copy);
rx->saved_copy = INT2PTR(SV*,*p);
void
Perl_rxres_free(pTHX_ void **rsp)
{
- UV *p = (UV*)*rsp;
+ UV * const p = (UV*)*rsp;
+ 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));
-#ifdef PERL_COPY_ON_WRITE
+#endif
+#ifdef PERL_OLD_COPY_ON_WRITE
if (p[1]) {
SvREFCNT_dec (INT2PTR(SV*,p[1]));
}
#endif
Safefree(p);
- *rsp = Null(void*);
+ *rsp = NULL;
}
}
PP(pp_formline)
{
- dSP; dMARK; dORIGMARK;
- register SV *tmpForm = *++MARK;
+ dVAR; dSP; dMARK; dORIGMARK;
+ register SV * const tmpForm = *++MARK;
register U32 *fpc;
register char *t;
- register char *f;
- register char *s;
- register char *send;
+ const char *f;
register I32 arg;
- register SV *sv = Nullsv;
- char *item = Nullch;
+ register SV *sv = NULL;
+ const char *item = NULL;
I32 itemsize = 0;
I32 fieldsize = 0;
I32 lines = 0;
- bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
- char *chophere = Nullch;
- char *linemark = Nullch;
+ bool chopspace = (strchr(PL_chopset, ' ') != NULL);
+ const char *chophere = NULL;
+ char *linemark = NULL;
NV value;
bool gotsome = FALSE;
STRLEN len;
- STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
+ const STRLEN fudge = SvPOK(tmpForm)
+ ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
- SV * nsv = Nullsv;
- OP * parseres = 0;
- char *fmt;
+ SV * nsv = NULL;
+ OP * parseres = NULL;
+ const char *fmt;
bool oneline;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
targ_is_utf8 = TRUE;
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
t += len;
- f = SvPV(tmpForm, len);
+ f = SvPV_const(tmpForm, len);
/* need to jump to the next word */
- s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
-
- fpc = (U32*)s;
+ fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
for (;;) {
DEBUG_f( {
- char *name = "???";
+ const char *name = "???";
arg = -1;
switch (*fpc) {
case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; 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_0DECIMAL: name = "0DECIMAL"; break;
case FF_LINESNGL: name = "LINESNGL"; break;
}
if (arg >= 0)
case FF_LITERAL:
arg = *fpc++;
if (targ_is_utf8 && !SvUTF8(tmpForm)) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
t = SvEND(PL_formtarget);
break;
}
if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_utf8_upgrade(PL_formtarget);
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
break;
case FF_CHECKNL:
- item = s = SvPV(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++;
+ {
+ 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 = 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;
}
- 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:
- item = s = SvPV(sv, len);
- itemsize = len;
- if (DO_UTF8(sv)) {
- itemsize = sv_len_utf8(sv);
- if (itemsize != (I32)len) {
- I32 itembytes;
- if (itemsize <= fieldsize) {
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - item;
- chophere = s;
- break;
- }
- if (*s++ & ~31)
- gotsome = TRUE;
- }
- }
- else {
- 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)
+ {
+ 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;
- if (*s == '\r')
break;
- }
- else {
- if (*s & ~31)
+ }
+ 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) {
- send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - item;
- chophere = s;
+ 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;
}
- if (*s++ & ~31)
- gotsome = TRUE;
}
- }
- else {
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send || (s == send && isSPACE(*s))) {
- if (isSPACE(*s)) {
- if (chopspace)
+ 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;
- if (*s == '\r')
break;
- }
- else {
- if (*s & ~31)
+ }
+ if (*s++ & ~31)
gotsome = TRUE;
- if (strchr(PL_chopset, *s))
- chophere = s + 1;
}
- s++;
}
- itemsize = chophere - item;
+ 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;
}
- break;
case FF_SPACE:
arg = fieldsize - itemsize;
break;
case FF_ITEM:
- arg = itemsize;
- s = item;
- if (item_is_utf8) {
- if (!targ_is_utf8) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- *t = '\0';
- sv_utf8_upgrade(PL_formtarget);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
- t = SvEND(PL_formtarget);
- targ_is_utf8 = TRUE;
- }
- while (arg--) {
- if (UTF8_IS_CONTINUED(*s)) {
- STRLEN skip = UTF8SKIP(s);
- switch (skip) {
- default:
- Move(s,t,skip,char);
- s += skip;
- t += skip;
- break;
- case 7: *t++ = *s++;
- case 6: *t++ = *s++;
- case 5: *t++ = *s++;
- case 4: *t++ = *s++;
- case 3: *t++ = *s++;
- case 2: *t++ = *s++;
- case 1: *t++ = *s++;
- }
+ {
+ const char *s = item;
+ arg = itemsize;
+ if (item_is_utf8) {
+ if (!targ_is_utf8) {
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
+ *t = '\0';
+ sv_utf8_upgrade(PL_formtarget);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ t = SvEND(PL_formtarget);
+ targ_is_utf8 = TRUE;
}
- else {
- if ( !((*t++ = *s++) & ~31) )
- t[-1] = ' ';
+ while (arg--) {
+ if (UTF8_IS_CONTINUED(*s)) {
+ STRLEN skip = UTF8SKIP(s);
+ switch (skip) {
+ default:
+ Move(s,t,skip,char);
+ s += skip;
+ t += skip;
+ break;
+ case 7: *t++ = *s++;
+ case 6: *t++ = *s++;
+ case 5: *t++ = *s++;
+ case 4: *t++ = *s++;
+ case 3: *t++ = *s++;
+ case 2: *t++ = *s++;
+ case 1: *t++ = *s++;
+ }
+ }
+ else {
+ if ( !((*t++ = *s++) & ~31) )
+ t[-1] = ' ';
+ }
}
+ break;
}
- break;
- }
- if (targ_is_utf8 && !item_is_utf8) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- *t = '\0';
- sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
- for (; t < SvEND(PL_formtarget); t++) {
+ if (targ_is_utf8 && !item_is_utf8) {
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
+ *t = '\0';
+ sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
+ for (; t < SvEND(PL_formtarget); t++) {
#ifdef EBCDIC
- int ch = *t;
- if (iscntrl(ch))
+ const int ch = *t;
+ if (iscntrl(ch))
#else
- if (!(*t & ~31))
+ if (!(*t & ~31))
#endif
- *t = ' ';
+ *t = ' ';
+ }
+ break;
}
- break;
- }
- while (arg--) {
+ while (arg--) {
#ifdef EBCDIC
- int ch = *t++ = *s++;
- if (iscntrl(ch))
+ const int ch = *t++ = *s++;
+ if (iscntrl(ch))
#else
- if ( !((*t++ = *s++) & ~31) )
+ if ( !((*t++ = *s++) & ~31) )
#endif
- t[-1] = ' ';
+ t[-1] = ' ';
+ }
+ break;
}
- break;
case FF_CHOP:
- s = chophere;
- if (chopspace) {
- while (*s && isSPACE(*s))
- s++;
+ {
+ const char *s = chophere;
+ if (chopspace) {
+ while (isSPACE(*s))
+ s++;
+ }
+ sv_chop(sv,s);
+ SvSETMAGIC(sv);
+ break;
}
- sv_chop(sv,s);
- SvSETMAGIC(sv);
- break;
case FF_LINESNGL:
chopspace = 0;
case FF_LINEGLOB:
oneline = FALSE;
ff_line:
- item = s = SvPV(sv, len);
- itemsize = len;
- if ((item_is_utf8 = DO_UTF8(sv)))
- itemsize = sv_len_utf8(sv);
- if (itemsize) {
- bool chopped = FALSE;
- gotsome = TRUE;
- send = s + len;
- chophere = s + itemsize;
- while (s < send) {
- if (*s++ == '\n') {
- if (oneline) {
- chopped = TRUE;
- chophere = s;
- break;
- } else {
- if (s == send) {
- itemsize--;
- chopped = TRUE;
- } else
- lines++;
+ {
+ const char *s = item = SvPV_const(sv, len);
+ itemsize = len;
+ if ((item_is_utf8 = DO_UTF8(sv)))
+ itemsize = sv_len_utf8(sv);
+ if (itemsize) {
+ bool chopped = FALSE;
+ const char *const send = s + len;
+ gotsome = TRUE;
+ chophere = s + itemsize;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (oneline) {
+ chopped = TRUE;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ itemsize--;
+ chopped = TRUE;
+ } else
+ lines++;
+ }
}
}
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
+ if (oneline) {
+ SvCUR_set(sv, chophere - item);
+ sv_catsv(PL_formtarget, sv);
+ SvCUR_set(sv, itemsize);
+ } else
+ sv_catsv(PL_formtarget, sv);
+ if (chopped)
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+ if (item_is_utf8)
+ targ_is_utf8 = TRUE;
}
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- if (targ_is_utf8)
- SvUTF8_on(PL_formtarget);
- if (oneline) {
- SvCUR_set(sv, chophere - item);
- sv_catsv(PL_formtarget, sv);
- SvCUR_set(sv, itemsize);
- } else
- sv_catsv(PL_formtarget, sv);
- if (chopped)
- SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
- t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
- if (item_is_utf8)
- targ_is_utf8 = TRUE;
+ break;
}
- break;
case FF_0DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
- fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
+ fmt = (const char *)
+ ((arg & 256) ?
+ "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
#else
- fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
+ fmt = (const char *)
+ ((arg & 256) ?
+ "%#0*.*f" : "%0*.*f");
#endif
goto ff_dec;
case FF_DECIMAL:
arg = *fpc++;
#if defined(USE_LONG_DOUBLE)
- fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
+ fmt = (const char *)
+ ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
#else
- fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
+ fmt = (const char *)
+ ((arg & 256) ? "%#*.*f" : "%*.*f");
#endif
ff_dec:
/* If the field is marked with ^ and the value is undefined,
gotsome = TRUE;
value = SvNV(sv);
/* overflow evidence */
- if (num_overflow(value, fieldsize, arg)) {
+ if (num_overflow(value, fieldsize, arg)) {
arg = fieldsize;
while (arg--)
*t++ = '#';
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
- sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
+ my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
*t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
lines += FmLINES(PL_formtarget);
if (lines == 200) {
arg = t - linemark;
break;
case FF_MORE:
- s = chophere;
- send = item + len;
- if (chopspace) {
- while (*s && isSPACE(*s) && s < send)
- s++;
- }
- if (s < send) {
- arg = fieldsize - itemsize;
- if (arg) {
- fieldsize -= arg;
- while (arg-- > 0)
- *t++ = ' ';
+ {
+ const char *s = chophere;
+ const char *send = item + len;
+ if (chopspace) {
+ while (isSPACE(*s) && (s < send))
+ s++;
}
- s = t - 3;
- if (strnEQ(s," ",3)) {
- while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
- 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++ = '.';
}
- *s++ = '.';
- *s++ = '.';
- *s++ = '.';
+ break;
}
- break;
-
case FF_END:
*t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
PP(pp_grepstart)
{
- dSP;
+ dVAR; dSP;
SV *src;
if (PL_stack_base + *PL_markstack_ptr == SP) {
return ((LOGOP*)PL_op->op_next)->op_other;
}
-PP(pp_mapstart)
-{
- DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
-}
-
PP(pp_mapwhile)
{
- dSP;
- I32 gimme = GIMME_V;
+ dVAR; dSP;
+ const I32 gimme = GIMME_V;
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
* irrelevant. --jhi */
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */
-
+
EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
while (items-- > 0)
*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
}
- else {
+ 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. */
PP(pp_range)
{
+ dVAR;
if (GIMME == G_ARRAY)
return NORMAL;
if (SvTRUEx(PAD_SV(PL_op->op_targ)))
PP(pp_flip)
{
+ dVAR;
dSP;
if (GIMME == G_ARRAY) {
}
else {
dTOPss;
- SV *targ = PAD_SV(PL_op->op_targ);
- int flip = 0;
+ SV * const targ = PAD_SV(PL_op->op_targ);
+ int flip = 0;
- if (PL_op->op_private & OPpFLIP_LINENUM) {
+ 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 *gv = gv_fetchpv(".", TRUE, SVt_PV);
- if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
+ 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) {
+ } 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);
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpv(TARG, "");
+ sv_setpvn(TARG, "", 0);
SETs(targ);
RETURN;
}
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(left) != '0')) \
+ looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
&& (!SvOK(right) || looks_like_number(right))))
PP(pp_flop)
{
- dSP;
+ dVAR; dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
- register IV i, j;
- register SV *sv;
- IV max;
- if (SvGMAGICAL(left))
- mg_get(left);
- if (SvGMAGICAL(right))
- mg_get(right);
+ 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");
else
j = 0;
while (j--) {
- sv = sv_2mortal(newSViv(i++));
+ SV * const sv = sv_2mortal(newSViv(i++));
PUSHs(sv);
}
}
else {
- SV *final = sv_mortalcopy(right);
- STRLEN len, n_a;
- char *tmps = SvPV(final, len);
+ SV * const final = sv_mortalcopy(right);
+ STRLEN len;
+ const char * const tmps = SvPV_const(final, len);
- sv = sv_mortalcopy(left);
- SvPV_force(sv,n_a);
+ SV *sv = sv_mortalcopy(left);
+ SvPV_force_nolen(sv);
while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
XPUSHs(sv);
- if (strEQ(SvPVX(sv),tmps))
+ if (strEQ(SvPVX_const(sv),tmps))
break;
sv = sv_2mortal(newSVsv(sv));
sv_inc(sv);
}
else {
dTOPss;
- SV *targ = PAD_SV(cUNOP->op_first->op_targ);
+ SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
int flop = 0;
sv_inc(targ);
flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
}
else {
- GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
+ GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
}
}
if (flop) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
- sv_catpv(targ, "E0");
+ sv_catpvs(targ, "E0");
}
SETs(targ);
}
/* Control. */
-static char *context_name[] = {
+static const char * const context_name[] = {
"pseudo-block",
"subroutine",
"eval",
"loop",
"substitution",
"block",
- "format"
+ "format",
+ "given",
+ "when"
};
STATIC I32
-S_dopoptolabel(pTHX_ char *label)
+S_dopoptolabel(pTHX_ const char *label)
{
+ dVAR;
register I32 i;
- register PERL_CONTEXT *cx;
for (i = cxstack_ix; i >= 0; i--) {
- cx = &cxstack[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:
+ case CXt_GIVEN:
+ case CXt_WHEN:
if (ckWARN(WARN_EXITING))
Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
context_name[CxTYPE(cx)], OP_NAME(PL_op));
return -1;
break;
case CXt_LOOP:
- if (!cx->blk_loop.label ||
- strNE(label, cx->blk_loop.label) ) {
+ if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
(long)i, cx->blk_loop.label));
continue;
return i;
}
+
+
I32
Perl_dowantarray(pTHX)
{
- I32 gimme = block_gimme();
+ dVAR;
+ const I32 gimme = block_gimme();
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
I32
Perl_block_gimme(pTHX)
{
- I32 cxix;
-
- cxix = dopoptosub(cxstack_ix);
+ dVAR;
+ const I32 cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
return G_VOID;
I32
Perl_is_lvalue_sub(pTHX)
{
- I32 cxix;
-
- cxix = dopoptosub(cxstack_ix);
+ dVAR;
+ const I32 cxix = dopoptosub(cxstack_ix);
assert(cxix >= 0); /* We should only be called from inside subs */
if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
STATIC I32
S_dopoptosub(pTHX_ I32 startingblock)
{
+ dVAR;
return dopoptosub_at(cxstack, startingblock);
}
STATIC I32
-S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
+S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
+ dVAR;
I32 i;
- register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstk[i];
+ register const PERL_CONTEXT * const cx = &cxstk[i];
switch (CxTYPE(cx)) {
default:
continue;
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
+ dVAR;
I32 i;
- register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
+ register const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
+ dVAR;
I32 i;
- register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
+ register const PERL_CONTEXT * const cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
return i;
}
+STATIC I32
+S_dopoptogiven(pTHX_ I32 startingblock)
+{
+ dVAR;
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_GIVEN:
+ DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
+ return i;
+ case CXt_LOOP:
+ if (CxFOREACHDEF(cx)) {
+ DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ }
+ return i;
+}
+
+STATIC I32
+S_dopoptowhen(pTHX_ I32 startingblock)
+{
+ dVAR;
+ I32 i;
+ for (i = startingblock; i >= 0; i--) {
+ register const PERL_CONTEXT *cx = &cxstack[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_WHEN:
+ DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
void
Perl_dounwind(pTHX_ I32 cxix)
{
- register PERL_CONTEXT *cx;
+ dVAR;
I32 optype;
while (cxstack_ix > cxix) {
SV *sv;
- cx = &cxstack[cxstack_ix];
+ register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
(long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
/* Note: we don't need to restore the base context info till the end. */
}
cxstack_ix--;
}
+ PERL_UNUSED_VAR(optype);
}
void
Perl_qerror(pTHX_ SV *err)
{
+ dVAR;
if (PL_in_eval)
sv_catsv(ERRSV, err);
else if (PL_errors)
sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%"SVf, err);
+ Perl_warn(aTHX_ "%"SVf, (void*)err);
++PL_error_count;
}
OP *
-Perl_die_where(pTHX_ char *message, STRLEN msglen)
+Perl_die_where(pTHX_ const char *message, STRLEN msglen)
{
- STRLEN n_a;
+ dVAR;
if (PL_in_eval) {
I32 cxix;
- register PERL_CONTEXT *cx;
I32 gimme;
- SV **newsp;
if (message) {
if (PL_in_eval & EVAL_KEEPERR) {
- static char prefix[] = "\t(in cleanup) ";
- SV *err = ERRSV;
- char *e = Nullch;
+ static const char prefix[] = "\t(in cleanup) ";
+ SV * const err = ERRSV;
+ const char *e = NULL;
if (!SvPOK(err))
- sv_setpv(err,"");
+ sv_setpvn(err,"",0);
else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
- e = SvPV(err, n_a);
- e += n_a - msglen;
+ STRLEN len;
+ e = SvPV_const(err, len);
+ e += len - msglen;
if (*e != *message || strNE(e,message))
- e = Nullch;
+ e = NULL;
}
if (!e) {
SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
sv_catpvn(err, prefix, sizeof(prefix)-1);
sv_catpvn(err, message, msglen);
if (ckWARN(WARN_MISC)) {
- STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
+ const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
+ Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
}
}
}
if (cxix >= 0) {
I32 optype;
+ register PERL_CONTEXT *cx;
+ SV **newsp;
if (cxix < cxstack_ix)
dounwind(cxix);
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
if (!message)
- message = SvPVx(ERRSV, msglen);
- PerlIO_write(Perl_error_log, "panic: die ", 11);
+ message = SvPVx_const(ERRSV, msglen);
+ PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
}
PL_curcop = cx->blk_oldcop;
if (optype == OP_REQUIRE) {
- char* msg = SvPVx(ERRSV, n_a);
- SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+ const char* const msg = SvPVx_nolen_const(ERRSV);
+ SV * const nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
- return pop_return();
+ assert(CxTYPE(cx) == CXt_EVAL);
+ return cx->blk_eval.retop;
}
}
if (!message)
- message = SvPVx(ERRSV, msglen);
+ message = SvPVx_const(ERRSV, msglen);
write_to_stderr(message, msglen);
my_failure_exit();
PP(pp_xor)
{
- dSP; dPOPTOPssrl;
+ dVAR; dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
RETSETNO;
}
-PP(pp_andassign)
-{
- dSP;
- if (!SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_orassign)
-{
- dSP;
- if (SvTRUE(TOPs))
- RETURN;
- else
- RETURNOP(cLOGOP->op_other);
-}
-
-PP(pp_dorassign)
-{
- dSP;
- register SV* sv;
-
- sv = TOPs;
- if (!sv || !SvANY(sv)) {
- RETURNOP(cLOGOP->op_other);
- }
-
- switch (SvTYPE(sv)) {
- case SVt_PVAV:
- if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- RETURN;
- break;
- case SVt_PVHV:
- if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- RETURN;
- break;
- case SVt_PVCV:
- if (CvROOT(sv) || CvXSUB(sv))
- RETURN;
- break;
- default:
- if (SvGMAGICAL(sv))
- mg_get(sv);
- if (SvOK(sv))
- RETURN;
- }
-
- RETURNOP(cLOGOP->op_other);
-}
-
PP(pp_caller)
{
+ dVAR;
dSP;
register I32 cxix = dopoptosub(cxstack_ix);
- register PERL_CONTEXT *cx;
- register PERL_CONTEXT *ccstack = cxstack;
- PERL_SI *top_si = PL_curstackinfo;
- I32 dbcxix;
+ register const PERL_CONTEXT *cx;
+ register const PERL_CONTEXT *ccstack = cxstack;
+ const PERL_SI *top_si = PL_curstackinfo;
I32 gimme;
- char *stashname;
- SV *sv;
+ const char *stashname;
I32 count = 0;
if (MAXARG)
}
RETURN;
}
- if (PL_DBsub && cxix >= 0 &&
+ /* 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--)
cx = &ccstack[cxix];
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- dbcxix = dopoptosub_at(ccstack, cxix - 1);
+ 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. */
- if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
+ /* 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;
}
- EXTEND(SP, 10);
+ EXTEND(SP, 11);
if (!stashname)
PUSHs(&PL_sv_undef);
if (!MAXARG)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
+ GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
/* So is ccstack[dbcxix]. */
if (isGV(cvgv)) {
- sv = NEWSV(49, 0);
- gv_efullname3(sv, cvgv, Nullch);
+ SV * const sv = newSV(0);
+ gv_efullname3(sv, cvgv, NULL);
PUSHs(sv_2mortal(sv));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
else {
- PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
+ PUSHs(sv_2mortal(newSVpvs("(unknown)")));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
}
else {
- PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
+ PUSHs(sv_2mortal(newSVpvs("(eval)")));
PUSHs(sv_2mortal(newSViv(0)));
}
gimme = (I32)cx->blk_gimme;
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
&& CopSTASH_eq(PL_curcop, PL_debstash))
{
- AV *ary = cx->blk_sub.argarray;
- int off = AvARRAY(ary) - AvALLOC(ary);
+ AV * const ary = cx->blk_sub.argarray;
+ const int off = AvARRAY(ary) - AvALLOC(ary);
if (!PL_dbargs) {
- GV* tmpgv;
- PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
- SVt_PVAV)));
+ GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
+ PL_dbargs = GvAV(gv_AVadd(tmpgv));
GvMULTI_on(tmpgv);
AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
}
/* XXX only hints propagated via op_private are currently
* visible (others are not easily accessible, since they
* use the global PL_hints) */
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
- HINT_PRIVATE_MASK)));
+ PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
{
SV * mask ;
- SV * old_warnings = cx->blk_oldcop->cop_warnings ;
+ STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
if (old_warnings == pWARN_NONE ||
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
/* Get the bit mask for $warnings::Bits{all}, because
* it could have been extended by warnings::register */
SV **bits_all;
- HV *bits = get_hv("warnings::Bits", FALSE);
- if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
+ HV * const bits = get_hv("warnings::Bits", FALSE);
+ if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
mask = newSVsv(*bits_all);
}
else {
}
}
else
- mask = newSVsv(old_warnings);
+ mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
PUSHs(sv_2mortal(mask));
}
+
+ PUSHs(cx->blk_oldcop->cop_hints_hash ?
+ sv_2mortal(newRV_noinc(
+ (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+ cx->blk_oldcop->cop_hints_hash)))
+ : &PL_sv_undef);
RETURN;
}
PP(pp_reset)
{
+ dVAR;
dSP;
- char *tmps;
- STRLEN n_a;
-
- if (MAXARG < 1)
- tmps = "";
- else
- tmps = POPpx;
+ const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
sv_reset(tmps, CopSTASH(PL_curcop));
PUSHs(&PL_sv_yes);
RETURN;
}
-PP(pp_lineseq)
-{
- return NORMAL;
-}
-
/* 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;
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
- register CV *cv;
register PERL_CONTEXT *cx;
- I32 gimme = G_ARRAY;
+ const I32 gimme = G_ARRAY;
U8 hasargs;
- GV *gv;
+ GV * const gv = PL_DBgv;
+ register CV * const cv = GvCV(gv);
- gv = PL_DBgv;
- cv = GvCV(gv);
if (!cv)
DIE(aTHX_ "No DB::DB routine defined");
hasargs = 0;
SPAGAIN;
- push_return(PL_op->op_next);
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB_DB(cx);
- CvDEPTH(cv)++;
- PAD_SET_CUR(CvPADLIST(cv),1);
- RETURNOP(CvSTART(cv));
+ 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;
}
-PP(pp_scope)
-{
- return NORMAL;
-}
-
PP(pp_enteriter)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
SV **svp;
- U32 cxtype = CXt_LOOP;
+ U16 cxtype = CXt_LOOP | CXp_FOREACH;
#ifdef USE_ITHREADS
void *iterdata;
#endif
#endif
}
else {
- GV *gv = (GV*)POPs;
+ GV * const gv = (GV*)POPs;
svp = &GvSV(gv); /* symbol table variable */
SAVEGENERICSV(*svp);
- *svp = NEWSV(0,0);
+ *svp = newSV(0);
#ifdef USE_ITHREADS
iterdata = (void*)gv;
#endif
}
+ if (PL_op->op_private & OPpITER_DEF)
+ cxtype |= CXp_FOR_DEF;
+
ENTER;
PUSHBLOCK(cx, cxtype, SP);
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
- SV *right = (SV*)cx->blk_loop.iterary;
+ SV * const right = (SV*)cx->blk_loop.iterary;
+ SvGETMAGIC(sv);
+ SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(sv,right)) {
if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
(SvOK(right) && SvNV(right) >= IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
cx->blk_loop.iterix = SvIV(sv);
cx->blk_loop.itermax = SvIV(right);
+#ifdef DEBUGGING
+ /* for correct -Dstv display */
+ cx->blk_oldsp = sp - PL_stack_base;
+#endif
}
else {
- STRLEN n_a;
cx->blk_loop.iterlval = newSVsv(sv);
- (void) SvPV_force(cx->blk_loop.iterlval,n_a);
- (void) SvPV(right,n_a);
+ (void) SvPV_force_nolen(cx->blk_loop.iterlval);
+ (void) SvPV_nolen_const(right);
}
}
else if (PL_op->op_private & OPpITER_REVERSED) {
- cx->blk_loop.itermax = -1;
- cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
+ cx->blk_loop.itermax = 0;
+ cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
}
}
cx->blk_loop.iterary = PL_curstack;
AvFILLp(PL_curstack) = SP - PL_stack_base;
if (PL_op->op_private & OPpITER_REVERSED) {
- cx->blk_loop.itermax = MARK - PL_stack_base;
- cx->blk_loop.iterix = cx->blk_oldsp;
+ cx->blk_loop.itermax = MARK - PL_stack_base + 1;
+ cx->blk_loop.iterix = cx->blk_oldsp + 1;
}
else {
cx->blk_loop.iterix = MARK - PL_stack_base;
PP(pp_enterloop)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
PP(pp_leaveloop)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
SV **mark;
POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_LOOP);
mark = newsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
TAINT_NOT;
if (gimme == G_VOID)
- ; /* do nothing */
+ NOOP;
else if (gimme == G_SCALAR) {
if (mark < SP)
*++newsp = sv_mortalcopy(*SP);
PP(pp_return)
{
- dSP; dMARK;
- I32 cxix;
+ dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
PMOP *newpm;
I32 optype = 0;
SV *sv;
+ OP *retop;
- if (PL_curstackinfo->si_type == PERLSI_SORT) {
- if (cxstack_ix == PL_sortcxix
- || dopoptosub(cxstack_ix) <= PL_sortcxix)
- {
- if (cxstack_ix > PL_sortcxix)
- dounwind(PL_sortcxix);
- AvARRAY(PL_curstack)[1] = *SP;
+ 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");
}
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- 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;
+ retop = cx->blk_sub.retop;
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);
+ retop = cx->blk_eval.retop;
if (CxTRYBLOCK(cx))
break;
lex_end();
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
/* Unassume the success we assumed earlier. */
- SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", nsv);
+ SV * const nsv = cx->blk_eval.old_namesv;
+ (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
+ DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
}
break;
case CXt_FORMAT:
POPFORMAT(cx);
+ retop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: return");
POPSUB(cx,sv); /* release CV and @_ ... */
}
else
- sv = Nullsv;
+ sv = NULL;
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
if (clear_errsv)
- sv_setpv(ERRSV,"");
- return pop_return();
+ sv_setpvn(ERRSV,"",0);
+ return retop;
}
PP(pp_last)
{
- dSP;
+ dVAR; dSP;
I32 cxix;
register PERL_CONTEXT *cx;
I32 pop2 = 0;
SV **newsp;
PMOP *newpm;
SV **mark;
- SV *sv = Nullsv;
+ SV *sv = NULL;
+
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
case CXt_LOOP:
pop2 = CXt_LOOP;
newsp = PL_stack_base + cx->blk_loop.resetsp;
- nextop = cx->blk_loop.last_op->op_next;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
break;
case CXt_SUB:
pop2 = CXt_SUB;
- nextop = pop_return();
+ nextop = cx->blk_sub.retop;
break;
case CXt_EVAL:
POPEVAL(cx);
- nextop = pop_return();
+ nextop = cx->blk_eval.retop;
break;
case CXt_FORMAT:
POPFORMAT(cx);
- nextop = pop_return();
+ nextop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: last");
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;
TOPBLOCK(cx);
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
- return cx->blk_loop.next_op;
+ PL_curcop = cx->blk_oldcop;
+ return CX_LOOP_NEXTOP_GET(cx);
}
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 < 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;
- return cx->blk_loop.redo_op;
+ PL_curcop = cx->blk_oldcop;
+ return redo_op;
}
STATIC OP *
-S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
+S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
{
- OP *kid = Nullop;
+ dVAR;
OP **ops = opstack;
- static char too_deep[] = "Target of goto is too deeply nested";
+ static const char too_deep[] = "Target of goto is too deeply nested";
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) &&
return 0;
}
-PP(pp_dump)
-{
- return pp_goto();
- /*NOTREACHED*/
-}
-
PP(pp_goto)
{
- dSP;
- OP *retop = 0;
+ dVAR; dSP;
+ OP *retop = NULL;
I32 ix;
register PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
- char *label;
- int do_dump = (PL_op->op_type == OP_DUMP);
- static char must_have_label[] = "goto must have label";
- AV *oldav = Nullav;
+ const char *label = NULL;
+ const bool do_dump = (PL_op->op_type == OP_DUMP);
+ static const char must_have_label[] = "goto must have label";
- label = 0;
if (PL_op->op_flags & OPf_STACKED) {
- SV *sv = POPs;
- STRLEN n_a;
+ SV * const sv = POPs;
/* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
SV** mark;
I32 items = 0;
I32 oldsave;
+ bool reified = 0;
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
- GV *gv = CvGV(cv);
- GV *autogv;
+ const GV * const gv = CvGV(cv);
if (gv) {
+ GV *autogv;
SV *tmpstr;
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
if (autogv && (cv = GvCV(autogv)))
goto retry;
tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
+ gv_efullname3(tmpstr, gv, NULL);
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
}
DIE(aTHX_ "Goto undefined subroutine");
}
/* First do some returnish stuff. */
- SvREFCNT_inc(cv); /* avoid premature free during unwind */
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
if (cxix < cxstack_ix)
dounwind(cxix);
TOPBLOCK(cx);
- if (CxREALEVAL(cx))
- DIE(aTHX_ "Can't goto subroutine from an eval-string");
- mark = PL_stack_sp;
+ 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 && cx->blk_sub.hasargs) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
-
+
items = AvFILLp(av) + 1;
- PL_stack_sp++;
- EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
- Copy(AvARRAY(av), PL_stack_sp, items, SV*);
- PL_stack_sp += items;
+ 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)) {
- oldav = av; /* delay until return */
+ reified = 1;
+ SvREFCNT_dec(av);
av = newAV();
av_extend(av, items-1);
- AvFLAGS(av) = AVf_REIFY;
+ AvREIFY_only(av);
PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
}
- else
- CLEAR_ARGARRAY(av);
}
- else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
- AV* av;
- av = GvAV(PL_defgv);
+ else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
+ AV* const av = GvAV(PL_defgv);
items = AvFILLp(av) + 1;
- PL_stack_sp++;
- EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
- Copy(AvARRAY(av), PL_stack_sp, items, SV*);
- PL_stack_sp += items;
+ 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);
/* Now do some callish stuff. */
SAVETMPS;
- /* For reified @_, delay freeing till return from new sub */
- if (oldav)
- SAVEFREESV((SV*)oldav);
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
- if (CvXSUB(cv)) {
-#ifdef PERL_XSUB_OLDSTYLE
- if (CvOLDSTYLE(cv)) {
- I32 (*fp3)(int,int,int);
- while (SP > mark) {
- SP[1] = SP[0];
- SP--;
- }
- fp3 = (I32(*)(int,int,int))CvXSUB(cv);
- items = (*fp3)(CvXSUBANY(cv).any_i32,
- mark - PL_stack_base + 1,
- items);
- SP = PL_stack_base + items;
- }
- else
-#endif /* PERL_XSUB_OLDSTYLE */
- {
- SV **newsp;
- I32 gimme;
-
- PL_stack_sp--; /* There is no cv arg. */
- /* Push a mark for the start of arglist */
- PUSHMARK(mark);
- (void)(*CvXSUB(cv))(aTHX_ cv);
- /* Pop the current context like a decent sub should */
- POPBLOCK(cx, PL_curpm);
- /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
+ if (CvISXSUB(cv)) {
+ OP* const retop = cx->blk_sub.retop;
+ SV **newsp;
+ I32 gimme;
+ if (reified) {
+ I32 index;
+ for (index=0; index<items; index++)
+ sv_2mortal(SP[-index]);
}
+
+ /* 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 pop_return();
+ return retop;
}
else {
- AV* padlist = CvPADLIST(cv);
+ AV* const padlist = CvPADLIST(cv);
if (CxTYPE(cx) == CXt_EVAL) {
PL_in_eval = cx->blk_eval.old_in_eval;
PL_eval_root = cx->blk_eval.old_eval_root;
cx->blk_sub.hasargs = 0;
}
cx->blk_sub.cv = cv;
- cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
+ cx->blk_sub.olddepth = CvDEPTH(cv);
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
+ SvREFCNT_inc_simple_void_NN(cv);
else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
- pad_push(padlist, CvDEPTH(cv), 1);
+ pad_push(padlist, CvDEPTH(cv));
}
- PAD_SET_CUR(padlist, CvDEPTH(cv));
+ SAVECOMPPAD();
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (cx->blk_sub.hasargs)
{
- AV* av = (AV*)PAD_SVl(0);
- SV** ary;
+ AV* const av = (AV*)PAD_SVl(0);
cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
- ++mark;
if (items >= AvMAX(av) + 1) {
- ary = AvALLOC(av);
+ SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
+ SvPV_set(av, (char*)ary);
}
if (items >= AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items+1,SV*);
AvALLOC(av) = ary;
- SvPVX(av) = (char*)ary;
+ SvPV_set(av, (char*)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);
* We do not care about using sv to call CV;
* it's for informational purposes only.
*/
- SV *sv = GvSV(PL_DBsub);
- CV *gotocv;
-
+ SV * const sv = GvSV(PL_DBsub);
+ save_item(sv);
if (PERLDB_SUB_NN) {
- (void)SvUPGRADE(sv, SVt_PVIV);
+ const int type = SvTYPE(sv);
+ if (type < SVt_PVIV && type != SVt_IV)
+ sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
- SAVEIV(SvIVX(sv));
- SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
+ SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
} else {
- save_item(sv);
- gv_efullname3(sv, CvGV(cv), Nullch);
+ gv_efullname3(sv, CvGV(cv), NULL);
}
- if ( PERLDB_GOTO
- && (gotocv = get_cv("DB::goto", FALSE)) ) {
- PUSHMARK( PL_stack_sp );
- call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
- PL_stack_sp--;
+ if (PERLDB_GOTO) {
+ CV * const gotocv = get_cv("DB::goto", FALSE);
+ if (gotocv) {
+ PUSHMARK( PL_stack_sp );
+ call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
+ PL_stack_sp--;
+ }
}
}
RETURNOP(CvSTART(cv));
}
}
else {
- label = SvPV(sv,n_a);
+ label = SvPV_nolen_const(sv);
if (!(do_dump || *label))
DIE(aTHX_ must_have_label);
}
label = cPVOP->op_pv;
if (label && *label) {
- OP *gotoprobe = 0;
+ OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
- PERL_CONTEXT *last_eval_cx = 0;
+ PERL_CONTEXT *last_eval_cx = NULL;
/* find label */
- PL_lastgotoprobe = 0;
+ PL_lastgotoprobe = NULL;
*enterops = 0;
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
gotoprobe = PL_main_root;
break;
case CXt_SUB:
- if (CvDEPTH(cx->blk_sub.cv)) {
+ if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
gotoprobe = CvROOT(cx->blk_sub.cv);
break;
}
/* push wanted frames */
if (*enterops && enterops[1]) {
- OP *oldop = PL_op;
+ OP * const oldop = PL_op;
ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
PP(pp_exit)
{
+ dVAR;
dSP;
I32 anum;
#endif
}
PL_exit_flags |= PERL_EXIT_EXPECTED;
+#ifdef PERL_MAD
+ /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
+ if (anum || !(PL_minus_c && PL_madskills))
+ my_exit(anum);
+#else
my_exit(anum);
+#endif
PUSHs(&PL_sv_undef);
RETURN;
}
-#ifdef NOTYET
-PP(pp_nswitch)
-{
- dSP;
- NV value = SvNVx(GvSV(cCOP->cop_gv));
- register I32 match = I_32(value);
-
- if (value < 0.0) {
- if (((NV)match) > value)
- --match; /* was fractional--truncate other way */
- }
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- PL_op = cCOP->uop.scop.scop_next[match];
- RETURNOP(PL_op);
-}
-
-PP(pp_cswitch)
-{
- dSP;
- register I32 match;
-
- if (PL_multiline)
- PL_op = PL_op->op_next; /* can't assume anything */
- else {
- STRLEN n_a;
- match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
- match -= cCOP->uop.scop.scop_offset;
- if (match < 0)
- match = 0;
- else if (match > cCOP->uop.scop.scop_max)
- match = cCOP->uop.scop.scop_max;
- PL_op = cCOP->uop.scop.scop_next[match];
- }
- RETURNOP(PL_op);
-}
-#endif
-
/* Eval. */
STATIC void
S_save_lines(pTHX_ AV *array, SV *sv)
{
- register char *s = SvPVX(sv);
- register char *send = SvPVX(sv) + SvCUR(sv);
- register char *t;
- register I32 line = 1;
+ const char *s = SvPVX_const(sv);
+ const char * const send = SvPVX_const(sv) + SvCUR(sv);
+ I32 line = 1;
while (s && s < send) {
- SV *tmpstr = NEWSV(85,0);
+ const char *t;
+ SV * const tmpstr = newSV(0);
sv_upgrade(tmpstr, SVt_PVMG);
t = strchr(s, '\n');
}
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_docatch_body(pTHX_ va_list args)
-{
- return docatch_body();
-}
-#endif
-
-STATIC void *
+STATIC void
S_docatch_body(pTHX)
{
+ dVAR;
CALLRUNOPS(aTHX);
- return NULL;
+ return;
}
STATIC OP *
S_docatch(pTHX_ OP *o)
{
+ dVAR;
int ret;
- OP *oldop = PL_op;
- OP *retop;
- volatile PERL_SI *cursi = PL_curstackinfo;
+ OP * const oldop = PL_op;
dJMPENV;
#ifdef DEBUGGING
#endif
PL_op = o;
- /* Normally, the leavetry at the end of this block of ops will
- * pop an op off the return stack and continue there. By setting
- * the op to Nullop, we force an exit from the inner runops()
- * loop. DAPM.
- */
- retop = pop_return();
- push_return(Nullop);
-
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
-#else
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ assert(cxstack_ix >= 0);
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
redo_body:
docatch_body();
-#endif
break;
case 3:
/* die caught by an inner eval - continue inner loop */
- if (PL_restartop && cursi == PL_curstackinfo) {
+
+ /* NB XXX we rely on the old popped CxEVAL still being at the top
+ * of the stack; the way die_where() currently works, this
+ * assumption is valid. In theory The cur_top_env value should be
+ * returned in another global, the way retop (aka PL_restartop)
+ * is. */
+ assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
+
+ if (PL_restartop
+ && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
+ {
PL_op = PL_restartop;
PL_restartop = 0;
goto redo_body;
}
- /* a die in this eval - continue in outer loop */
- if (!PL_restartop)
- break;
/* FALL THROUGH */
default:
JMPENV_POP;
}
JMPENV_POP;
PL_op = oldop;
- return retop;
+ return NULL;
}
OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
+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. */
{
- dSP; /* Make POPBLOCK work. */
+ /* FIXME - how much of this code is common with pp_entereval? */
+ dVAR; dSP; /* Make POPBLOCK work. */
PERL_CONTEXT *cx;
SV **newsp;
- I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
+ I32 gimme = G_VOID;
I32 optype;
OP dummy;
OP *rop;
char *tmpbuf = tbuf;
char *safestr;
int runtime;
- CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
+ CV* runcv = NULL; /* initialise to avoid compiler warnings */
+ STRLEN len;
ENTER;
lex_start(sv);
CopSTASH_set(&PL_compiling, PL_curstash);
}
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV *sv = sv_newmortal();
+ 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
- sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
+ (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
(i.e. before run-time proper). To work around the coredump that
ensues, we always turn GvMULTI_on for any globals that were
introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepv(tmpbuf);
- SAVEDELETE(PL_defstash, safestr, strlen(safestr));
+ safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
SAVEHINTS();
#ifdef OP_IN_REGISTER
PL_opsave = op;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
- PUSHEVAL(cx, 0, Nullgv);
+ PUSHEVAL(cx, 0, NULL);
if (runtime)
rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
lex_end();
/* XXX DAPM do this properly one year */
- *padp = (AV*)SvREFCNT_inc(PL_comppad);
+ *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
LEAVE;
if (IN_PERL_COMPILETIME)
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
#ifdef OP_IN_REGISTER
op = PL_opsave;
#endif
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(optype);
+
return rop;
}
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 in the scope of the debugger itself).
+than in the scope of the debugger itself).
=cut
*/
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
- I32 ix;
+ dVAR;
PERL_SI *si;
- PERL_CONTEXT *cx;
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--) {
- cx = &(si->si_cxstack[ix]);
+ const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- CV *cv = cx->blk_sub.cv;
+ 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;
STATIC OP *
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
- dSP;
- OP *saveop = PL_op;
+ dVAR; dSP;
+ OP * const saveop = PL_op;
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
PUSHMARK(SP);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)NEWSV(1104,0);
+ PL_compcv = (CV*)newSV(0);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvEVAL_on(PL_compcv);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
/* set up a scratch pad */
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+ PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
- SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
+ if (!PL_madskills)
+ SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
SAVEFREESV(PL_beginav);
SAVEI32(PL_error_count);
+#ifdef PERL_MAD
+ SAVEI32(PL_madskills);
+ PL_madskills = 0;
+#endif
+
/* try to compile it */
- PL_eval_root = Nullop;
+ PL_eval_root = NULL;
PL_error_count = 0;
PL_curcop = &PL_compiling;
- PL_curcop->cop_arybase = 0;
- if (saveop && saveop->op_flags & OPf_SPECIAL)
+ CopARYBASE_set(PL_curcop, 0);
+ if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
if (yyparse() || PL_error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
- PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
I32 optype = 0; /* Might be reset by POPEVAL. */
- STRLEN n_a;
-
+ const char *msg;
+
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
- PL_eval_root = Nullop;
+ PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
if (!startop) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
- pop_return();
}
lex_end();
LEAVE;
+
+ msg = SvPVx_nolen_const(ERRSV);
if (optype == OP_REQUIRE) {
- char* msg = SvPVx(ERRSV, n_a);
- SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+ const SV * const nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
&PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
else if (startop) {
- char* msg = SvPVx(ERRSV, n_a);
-
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
else {
- char* msg = SvPVx(ERRSV, n_a);
if (!*msg) {
sv_setpv(ERRSV, "Compilation error");
}
}
+ PERL_UNUSED_VAR(newsp);
RETPUSHUNDEF;
}
CopLINE_set(&PL_compiling, 0);
DEBUG_x(dump_eval());
/* Register with debugger: */
- if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
- CV *cv = get_cv("DB::postponed", FALSE);
+ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
+ CV * const cv = get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
PUSHMARK(SP);
}
STATIC PerlIO *
+S_check_type_and_open(pTHX_ const char *name, const char *mode)
+{
+ Stat_t st;
+ const int st_rc = PerlLIO_stat(name, &st);
+
+ if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
+ return NULL;
+ }
+
+ return PerlIO_open(name, mode);
+}
+
+STATIC PerlIO *
S_doopen_pm(pTHX_ const char *name, const char *mode)
{
#ifndef PERL_DISABLE_PMC
- STRLEN namelen = strlen(name);
+ const STRLEN namelen = strlen(name);
PerlIO *fp;
if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
- SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
- char *pmc = SvPV_nolen(pmcsv);
- Stat_t pmstat;
+ SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
+ const char * const pmc = SvPV_nolen_const(pmcsv);
Stat_t pmcstat;
if (PerlLIO_stat(pmc, &pmcstat) < 0) {
- fp = PerlIO_open(name, mode);
+ fp = check_type_and_open(name, mode);
}
else {
- if (PerlLIO_stat(name, &pmstat) < 0 ||
- pmstat.st_mtime < pmcstat.st_mtime)
- {
- fp = PerlIO_open(pmc, mode);
- }
- else {
- fp = PerlIO_open(name, mode);
- }
+ fp = check_type_and_open(pmc, mode);
}
SvREFCNT_dec(pmcsv);
}
else {
- fp = PerlIO_open(name, mode);
+ fp = check_type_and_open(name, mode);
}
return fp;
#else
- return PerlIO_open(name, mode);
+ return check_type_and_open(name, mode);
#endif /* !PERL_DISABLE_PMC */
}
PP(pp_require)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
SV *sv;
- char *name;
+ const char *name;
STRLEN len;
- char *tryname = Nullch;
- SV *namesv = Nullsv;
- SV** svp;
- I32 gimme = GIMME_V;
- PerlIO *tryrsfp = 0;
- STRLEN n_a;
+ const char *tryname = NULL;
+ SV *namesv = NULL;
+ const I32 gimme = GIMME_V;
int filter_has_file = 0;
- GV *filter_child_proc = 0;
- SV *filter_state = 0;
- SV *filter_sub = 0;
- SV *hook_sv = 0;
+ PerlIO *tryrsfp = NULL;
+ SV *filter_cache = NULL;
+ SV *filter_state = NULL;
+ SV *filter_sub = NULL;
+ SV *hook_sv = NULL;
SV *encoding;
OP *op;
sv = POPs;
- if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
- if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
- UV rev = 0, ver = 0, sver = 0;
- STRLEN len;
- U8 *s = (U8*)SvPVX(sv);
- U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
- if (s < end) {
- rev = utf8n_to_uvchr(s, end - s, &len, 0);
- s += len;
- if (s < end) {
- ver = utf8n_to_uvchr(s, end - s, &len, 0);
- s += len;
- if (s < end)
- sver = utf8n_to_uvchr(s, end - s, &len, 0);
- }
- }
- if (PERL_REVISION < rev
- || (PERL_REVISION == rev
- && (PERL_VERSION < ver
- || (PERL_VERSION == ver
- && PERL_SUBVERSION < sver))))
- {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
- "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
- PERL_VERSION, PERL_SUBVERSION);
- }
- if (ckWARN(WARN_PORTABLE))
+ if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
+ if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"v-string in use/require non-portable");
- RETPUSHYES;
+
+ sv = new_version(sv);
+ if (!sv_derived_from(PL_patchlevel, "version"))
+ upg_version(PL_patchlevel);
+ 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",
+ (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
}
- else if (!SvPOKp(sv)) { /* require 5.005_03 */
- if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
- + ((NV)PERL_SUBVERSION/(NV)1000000)
- + 0.00000099 < SvNV(sv))
- {
- NV nrev = SvNV(sv);
- UV rev = (UV)nrev;
- NV nver = (nrev - rev) * 1000;
- UV ver = (UV)(nver + 0.0009);
- NV nsver = (nver - ver) * 1000;
- UV sver = (UV)(nsver + 0.0009);
-
- /* help out with the "use 5.6" confusion */
- if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
- " (did you mean v%"UVuf".%03"UVuf"?)--"
- "this is only v%d.%d.%d, stopped",
- rev, ver, sver, rev, ver/100,
- PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
- }
- else {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
- "this is only v%d.%d.%d, stopped",
- rev, ver, sver, PERL_REVISION, PERL_VERSION,
- PERL_SUBVERSION);
- }
- }
- RETPUSHYES;
+ else {
+ if ( vcmp(sv,PL_patchlevel) > 0 )
+ DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
+ (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
}
+
+ RETPUSHYES;
}
- name = SvPV(sv, len);
+ name = SvPV_const(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
TAINT_PROPER("require");
- if (PL_op->op_type == OP_REQUIRE &&
- (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
- if (*svp != &PL_sv_undef)
- RETPUSHYES;
- else
- DIE(aTHX_ "Compilation failed in require");
+ if (PL_op->op_type == OP_REQUIRE) {
+ SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if ( svp ) {
+ if (*svp != &PL_sv_undef)
+ RETPUSHYES;
+ else
+ DIE(aTHX_ "Compilation failed in require");
+ }
}
/* prepare to compile file */
}
#endif
if (!tryrsfp) {
- AV *ar = GvAVn(PL_incgv);
+ AV * const ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
char *unixname;
- if ((unixname = tounixspec(name, Nullch)) != Nullch)
+ if ((unixname = tounixspec(name, NULL)) != NULL)
#endif
{
- namesv = NEWSV(806, 0);
+ namesv = newSV(0);
for (i = 0; i <= AvFILL(ar); i++) {
- SV *dirsv = *av_fetch(ar, i, TRUE);
+ SV * const dirsv = *av_fetch(ar, i, TRUE);
if (SvROK(dirsv)) {
int count;
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
PTR2UV(SvRV(dirsv)), name);
- tryname = SvPVX(namesv);
- tryrsfp = 0;
+ tryname = SvPVX_const(namesv);
+ tryrsfp = NULL;
ENTER;
SAVETMPS;
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) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
arg = SvRV(arg);
}
if (SvTYPE(arg) == SVt_PVGV) {
- IO *io = GvIO((GV *)arg);
+ IO * const io = GvIO((GV *)arg);
++filter_has_file;
if (io) {
tryrsfp = IoIFP(io);
- if (IoTYPE(io) == IoTYPE_PIPE) {
- /* reading from a child process doesn't
- nest -- when returning from reading
- the inner module, the outer one is
- unreadable (closed?) I've tried to
- save the gv to manage the lifespan of
- the pipe, but this didn't help. XXX */
- filter_child_proc = (GV *)arg;
- (void)SvREFCNT_inc(filter_child_proc);
- }
- else {
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
- PerlIO_close(IoOFP(io));
- }
- IoIFP(io) = Nullfp;
- IoOFP(io) = Nullfp;
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+ PerlIO_close(IoOFP(io));
}
+ IoIFP(io) = NULL;
+ IoOFP(io) = NULL;
}
if (i < count) {
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
filter_sub = arg;
- (void)SvREFCNT_inc(filter_sub);
+ SvREFCNT_inc_simple_void_NN(filter_sub);
if (i < count) {
filter_state = SP[i];
- (void)SvREFCNT_inc(filter_state);
+ SvREFCNT_inc_simple_void(filter_state);
}
+ }
- if (tryrsfp == 0) {
- tryrsfp = PerlIO_open("/dev/null",
- PERL_SCRIPT_MODE);
- }
+ if (!tryrsfp && (filter_cache || filter_sub)) {
+ tryrsfp = PerlIO_open(BIT_BUCKET,
+ PERL_SCRIPT_MODE);
}
SP--;
}
}
filter_has_file = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- filter_child_proc = 0;
+ if (filter_cache) {
+ SvREFCNT_dec(filter_cache);
+ filter_cache = NULL;
}
if (filter_state) {
SvREFCNT_dec(filter_state);
- filter_state = 0;
+ filter_state = NULL;
}
if (filter_sub) {
SvREFCNT_dec(filter_sub);
- filter_sub = 0;
+ filter_sub = NULL;
}
}
else {
|| (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
#endif
) {
- char *dir = SvPVx(dirsv, n_a);
+ const char *dir = SvPVx_nolen_const(dirsv);
#ifdef MACOS_TRADITIONAL
char buf1[256];
char buf2[256];
MacPerl_CanonDir(name, buf2, 1);
Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
#else
-#ifdef VMS
+# ifdef VMS
char *unixdir;
- if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+ if ((unixdir = tounixpath(dir, NULL)) == NULL)
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
-#else
+# 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
Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
-#endif
+# endif
+# endif
#endif
TAINT_PROPER("require");
- tryname = SvPVX(namesv);
+ tryname = SvPVX_const(namesv);
tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/')
tryname += 2;
break;
}
+ else if (errno == EMFILE)
+ /* no point in trying other paths if out of handles */
+ break;
}
}
}
SvREFCNT_dec(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
- char *msgstr = name;
- if (namesv) { /* did we lookup @INC? */
- SV *msg = sv_2mortal(newSVpv(msgstr,0));
- SV *dirmsgsv = NEWSV(0, 0);
- AV *ar = GvAVn(PL_incgv);
- I32 i;
- sv_catpvn(msg, " in @INC", 8);
- if (instr(SvPVX(msg), ".h "))
- sv_catpv(msg, " (change .h to .ph maybe?)");
- if (instr(SvPVX(msg), ".ph "))
- sv_catpv(msg, " (did you run h2ph?)");
- sv_catpv(msg, " (@INC contains:");
- for (i = 0; i <= AvFILL(ar); i++) {
- char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
- Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
- sv_catsv(msg, dirmsgsv);
- }
- sv_catpvn(msg, ")", 1);
- SvREFCNT_dec(dirmsgsv);
- msgstr = SvPV_nolen(msg);
+ const char *msgstr = name;
+ if(errno == EMFILE) {
+ SV * const msg
+ = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
+ Strerror(errno)));
+ msgstr = SvPV_nolen_const(msg);
+ } else {
+ if (namesv) { /* did we lookup @INC? */
+ AV * const ar = GvAVn(PL_incgv);
+ I32 i;
+ SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
+ "%s in @INC%s%s (@INC contains:",
+ msgstr,
+ (instr(msgstr, ".h ")
+ ? " (change .h to .ph maybe?)" : ""),
+ (instr(msgstr, ".ph ")
+ ? " (did you run h2ph?)" : "")
+ ));
+
+ for (i = 0; i <= AvFILL(ar); i++) {
+ sv_catpvs(msg, " ");
+ sv_catsv(msg, *av_fetch(ar, i, TRUE));
+ }
+ sv_catpvs(msg, ")");
+ msgstr = SvPV_nolen_const(msg);
+ }
}
DIE(aTHX_ "Can't locate %s", msgstr);
}
SETERRNO(0, SS_NORMAL);
/* Assume success here to prevent recursive requirement. */
- len = strlen(name);
+ /* 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 || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
- (void)hv_store(GvHVn(PL_incgv), name, len,
- (hook_sv ? SvREFCNT_inc(hook_sv)
- : newSVpv(CopFILE(&PL_compiling), 0)),
- 0 );
+ if (!hook_sv) {
+ (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
+ } else {
+ SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (!svp)
+ (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
}
ENTER;
SAVETMPS;
- lex_start(sv_2mortal(newSVpvn("",0)));
+ lex_start(sv_2mortal(newSVpvs("")));
SAVEGENERICSV(PL_rsfp_filters);
- PL_rsfp_filters = Nullav;
+ PL_rsfp_filters = NULL;
PL_rsfp = tryrsfp;
SAVEHINTS();
PL_hints = 0;
- SAVESPTR(PL_compiling.cop_warnings);
+ SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
PL_compiling.cop_warnings = pWARN_NONE ;
- else if (PL_taint_warn)
- PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+ else if (PL_taint_warn) {
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
+ }
else
PL_compiling.cop_warnings = pWARN_STD ;
- SAVESPTR(PL_compiling.cop_io);
- PL_compiling.cop_io = Nullsv;
- if (filter_sub || filter_child_proc) {
- SV *datasv = filter_add(run_user_filter, Nullsv);
+ if (filter_sub || filter_cache) {
+ SV * const datasv = filter_add(S_run_user_filter, NULL);
IoLINES(datasv) = filter_has_file;
- IoFMT_GV(datasv) = (GV *)filter_child_proc;
IoTOP_GV(datasv) = (GV *)filter_state;
IoBOTTOM_GV(datasv) = (GV *)filter_sub;
+ IoFMT_GV(datasv) = (GV *)filter_cache;
}
/* switch to eval mode */
- push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_EVAL, SP);
- PUSHEVAL(cx, name, Nullgv);
+ PUSHEVAL(cx, name, NULL);
+ cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 0);
/* Store and reset encoding. */
encoding = PL_encoding;
- PL_encoding = Nullsv;
+ PL_encoding = NULL;
+
+ op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
- op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
-
/* Restore encoding. */
PL_encoding = encoding;
return op;
}
-PP(pp_dofile)
-{
- return pp_require();
-}
-
PP(pp_entereval)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
- dPOPss;
- I32 gimme = GIMME_V, was = PL_sub_generation;
+ SV *sv;
+ const I32 gimme = GIMME_V;
+ const I32 was = PL_sub_generation;
char tbuf[TYPE_DIGITS(long) + 12];
char *tmpbuf = tbuf;
char *safestr;
OP *ret;
CV* runcv;
U32 seq;
+ HV *saved_hh = NULL;
+ const char * const fakestr = "_<(eval )";
+ const int fakelen = 9 + 1;
+
+ if (PL_op->op_private & OPpEVAL_HAS_HH) {
+ saved_hh = (HV*) SvREFCNT_inc(POPs);
+ }
+ sv = POPs;
- if (!SvPV(sv,len))
+ if (!SvPV_nolen_const(sv))
RETPUSHUNDEF;
TAINT_PROPER("eval");
/* switch to eval mode */
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
- SV *sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
+ SV * const temp_sv = sv_newmortal();
+ Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
(unsigned long)++PL_evalseq,
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
- tmpbuf = SvPVX(sv);
+ tmpbuf = SvPVX(temp_sv);
+ len = SvCUR(temp_sv);
}
else
- sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
SAVECOPLINE(&PL_compiling);
(i.e. before run-time proper). To work around the coredump that
ensues, we always turn GvMULTI_on for any globals that were
introduced within evals. See force_ident(). GSAR 96-10-12 */
- safestr = savepv(tmpbuf);
- SAVEDELETE(PL_defstash, safestr, strlen(safestr));
+ safestr = savepvn(tmpbuf, len);
+ SAVEDELETE(PL_defstash, safestr, len);
SAVEHINTS();
PL_hints = PL_op->op_targ;
- SAVESPTR(PL_compiling.cop_warnings);
- if (specialWARN(PL_curcop->cop_warnings))
- PL_compiling.cop_warnings = PL_curcop->cop_warnings;
- else {
- PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
- SAVEFREESV(PL_compiling.cop_warnings);
+ if (saved_hh)
+ GvHV(PL_hintgv) = saved_hh;
+ SAVECOMPILEWARNINGS();
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
}
- SAVESPTR(PL_compiling.cop_io);
- if (specialCopIO(PL_curcop->cop_io))
- PL_compiling.cop_io = PL_curcop->cop_io;
- else {
- PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
- SAVEFREESV(PL_compiling.cop_io);
+ PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (PL_compiling.cop_hints_hash) {
+ HINTS_REFCNT_LOCK;
+ PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
}
/* special case: an eval '' executed within the DB package gets lexically
* placed in the first non-DB CV rather than the current CV - this
* to do the dirty work for us */
runcv = find_runcv(&seq);
- push_return(PL_op->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
- PUSHEVAL(cx, 0, Nullgv);
+ PUSHEVAL(cx, 0, NULL);
+ cx->blk_eval.retop = PL_op->op_next;
/* prepare to compile string */
ret = doeval(gimme, NULL, runcv, seq);
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
&& ret != PL_op->op_next) { /* Successive compilation. */
- strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ /* Copy in anything fake and short. */
+ my_strlcpy(safestr, fakestr, fakelen);
}
return DOCATCH(ret);
}
PP(pp_leaveeval)
{
- dSP;
+ dVAR; dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
I32 gimme;
register PERL_CONTEXT *cx;
OP *retop;
- U8 save_flags = PL_op -> op_flags;
+ const U8 save_flags = PL_op -> op_flags;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
+ retop = cx->blk_eval.retop;
TAINT_NOT;
if (gimme == G_VOID)
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
{
/* Unassume the success we assumed earlier. */
- SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
+ SV * const nsv = cx->blk_eval.old_namesv;
+ (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
/* die_where() did LEAVE, or we won't be here */
}
else {
LEAVE;
if (!(save_flags & OPf_SPECIAL))
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
}
RETURNOP(retop);
}
-PP(pp_entertry)
+/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
+ close to the related Perl_create_eval_scope. */
+void
+Perl_delete_eval_scope(pTHX)
{
- dSP;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ PL_curpm = newpm;
+ LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
+}
+/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
+ also needed by Perl_fold_constants. */
+PERL_CONTEXT *
+Perl_create_eval_scope(pTHX_ U32 flags)
+{
+ PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
ENTER;
SAVETMPS;
- push_return(cLOGOP->op_other->op_next);
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
+ PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
PL_in_eval = EVAL_INEVAL;
- sv_setpv(ERRSV,"");
- PUTBACK;
+ if (flags & G_KEEPERR)
+ PL_in_eval |= EVAL_KEEPERR;
+ else
+ sv_setpvn(ERRSV,"",0);
+ if (flags & G_FAKINGEVAL) {
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
+ }
+ return cx;
+}
+
+PP(pp_entertry)
+{
+ dVAR;
+ PERL_CONTEXT * const cx = create_eval_scope(0);
+ cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
}
PP(pp_leavetry)
{
- dSP;
- register SV **mark;
+ dVAR; dSP;
SV **newsp;
PMOP *newpm;
- OP* retop;
I32 gimme;
register PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
+ PERL_UNUSED_VAR(optype);
TAINT_NOT;
if (gimme == G_VOID)
SP = newsp;
else if (gimme == G_SCALAR) {
+ register SV **mark;
MARK = newsp + 1;
if (MARK <= SP) {
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
}
else {
/* in case LEAVE wipes old return values */
+ register SV **mark;
for (mark = newsp + 1; mark <= SP; mark++) {
if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
*mark = sv_mortalcopy(*mark);
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(ERRSV,"");
- RETURNOP(retop);
+ sv_setpvn(ERRSV,"",0);
+ RETURN;
+}
+
+PP(pp_entergiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ ENTER;
+ SAVETMPS;
+
+ if (PL_op->op_targ == 0) {
+ SV ** const defsv_p = &GvSV(PL_defgv);
+ *defsv_p = newSVsv(POPs);
+ SAVECLEARSV(*defsv_p);
+ }
+ else
+ sv_setsv(PAD_SV(PL_op->op_targ), POPs);
+
+ PUSHBLOCK(cx, CXt_GIVEN, SP);
+ PUSHGIVEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavegiven)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+ PERL_UNUSED_CONTEXT;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_GIVEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+
+ return NORMAL;
+}
+
+/* Helper routines used by pp_smartmatch */
+STATIC
+PMOP *
+S_make_matcher(pTHX_ regexp *re)
+{
+ dVAR;
+ PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
+ PM_SETRE(matcher, ReREFCNT_inc(re));
+
+ SAVEFREEOP((OP *) matcher);
+ ENTER; SAVETMPS;
+ SAVEOP();
+ return matcher;
+}
+
+STATIC
+bool
+S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
+{
+ dVAR;
+ dSP;
+
+ PL_op = (OP *) matcher;
+ XPUSHs(sv);
+ PUTBACK;
+ (void) pp_match();
+ SPAGAIN;
+ return (SvTRUEx(POPs));
+}
+
+STATIC
+void
+S_destroy_matcher(pTHX_ PMOP *matcher)
+{
+ dVAR;
+ PERL_UNUSED_ARG(matcher);
+ FREETMPS;
+ LEAVE;
+}
+
+/* Do a smart match */
+PP(pp_smartmatch)
+{
+ return do_smartmatch(NULL, NULL);
+}
+
+/* This version of do_smartmatch() implements the
+ * table of smart matches that is found in perlsyn.
+ */
+STATIC
+OP *
+S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
+{
+ dVAR;
+ dSP;
+
+ SV *e = TOPs; /* e is for 'expression' */
+ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
+ SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
+ MAGIC *mg;
+ regexp *this_regex, *other_regex;
+
+# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
+
+# define SM_REF(type) ( \
+ (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
+ || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
+
+# define SM_CV_NEP /* Find a code ref without an empty prototype */ \
+ ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
+ && NOT_EMPTY_PROTO(This) && (Other = e)) \
+ || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
+ && NOT_EMPTY_PROTO(This) && (Other = d)))
+
+# define SM_REGEX ( \
+ (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
+ && (mg = mg_find(This, PERL_MAGIC_qr)) \
+ && (this_regex = (regexp *)mg->mg_obj) \
+ && (Other = e)) \
+ || \
+ (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
+ && (mg = mg_find(This, PERL_MAGIC_qr)) \
+ && (this_regex = (regexp *)mg->mg_obj) \
+ && (Other = d)) )
+
+
+# define SM_OTHER_REF(type) \
+ (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
+
+# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
+ && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
+ && (other_regex = (regexp *)mg->mg_obj))
+
+
+# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
+ sv_2mortal(newSViv(PTR2IV(sv))), 0)
+
+# define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
+ sv_2mortal(newSViv(PTR2IV(sv))), 0)
+
+ tryAMAGICbinSET(smart, 0);
+
+ SP -= 2; /* Pop the values */
+
+ /* Take care only to invoke mg_get() once for each argument.
+ * Currently we do this by copying the SV if it's magical. */
+ if (d) {
+ if (SvGMAGICAL(d))
+ d = sv_mortalcopy(d);
+ }
+ else
+ d = &PL_sv_undef;
+
+ assert(e);
+ if (SvGMAGICAL(e))
+ e = sv_mortalcopy(e);
+
+ if (SM_CV_NEP) {
+ I32 c;
+
+ if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
+ {
+ if (This == SvRV(Other))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUSHs(Other);
+ PUTBACK;
+ c = call_sv(This, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_no);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc_void(TOPs);
+ FREETMPS;
+ LEAVE;
+ RETURN;
+ }
+ else if (SM_REF(PVHV)) {
+ if (SM_OTHER_REF(PVHV)) {
+ /* Check that the key-sets are identical */
+ HE *he;
+ HV *other_hv = (HV *) SvRV(Other);
+ bool tied = FALSE;
+ bool other_tied = FALSE;
+ U32 this_key_count = 0,
+ other_key_count = 0;
+
+ /* Tied hashes don't know how many keys they have. */
+ if (SvTIED_mg(This, PERL_MAGIC_tied)) {
+ tied = TRUE;
+ }
+ else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
+ HV * const temp = other_hv;
+ other_hv = (HV *) This;
+ This = (SV *) temp;
+ tied = TRUE;
+ }
+ if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
+ other_tied = TRUE;
+
+ if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
+ RETPUSHNO;
+
+ /* The hashes have the same number of keys, so it suffices
+ to check that one is a subset of the other. */
+ (void) hv_iterinit((HV *) This);
+ while ( (he = hv_iternext((HV *) This)) ) {
+ I32 key_len;
+ char * const key = hv_iterkey(he, &key_len);
+
+ ++ this_key_count;
+
+ if(!hv_exists(other_hv, key, key_len)) {
+ (void) hv_iterinit((HV *) This); /* reset iterator */
+ RETPUSHNO;
+ }
+ }
+
+ if (other_tied) {
+ (void) hv_iterinit(other_hv);
+ while ( hv_iternext(other_hv) )
+ ++other_key_count;
+ }
+ else
+ other_key_count = HvUSEDKEYS(other_hv);
+
+ if (this_key_count != other_key_count)
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ }
+ else if (SM_OTHER_REF(PVAV)) {
+ AV * const other_av = (AV *) SvRV(Other);
+ const I32 other_len = av_len(other_av) + 1;
+ I32 i;
+
+ if (HvUSEDKEYS((HV *) This) != other_len)
+ RETPUSHNO;
+
+ for(i = 0; i < other_len; ++i) {
+ SV ** const svp = av_fetch(other_av, i, FALSE);
+ char *key;
+ STRLEN key_len;
+
+ if (!svp) /* ??? When can this happen? */
+ RETPUSHNO;
+
+ key = SvPV(*svp, key_len);
+ if(!hv_exists((HV *) This, key, key_len))
+ RETPUSHNO;
+ }
+ RETPUSHYES;
+ }
+ else if (SM_OTHER_REGEX) {
+ PMOP * const matcher = make_matcher(other_regex);
+ HE *he;
+
+ (void) hv_iterinit((HV *) This);
+ while ( (he = hv_iternext((HV *) This)) ) {
+ if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+ (void) hv_iterinit((HV *) This);
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ else {
+ if (hv_exists_ent((HV *) This, Other, 0))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ }
+ else if (SM_REF(PVAV)) {
+ if (SM_OTHER_REF(PVAV)) {
+ AV *other_av = (AV *) SvRV(Other);
+ if (av_len((AV *) This) != av_len(other_av))
+ RETPUSHNO;
+ else {
+ I32 i;
+ const I32 other_len = av_len(other_av);
+
+ if (NULL == seen_this) {
+ seen_this = newHV();
+ (void) sv_2mortal((SV *) seen_this);
+ }
+ if (NULL == seen_other) {
+ seen_this = newHV();
+ (void) sv_2mortal((SV *) seen_other);
+ }
+ for(i = 0; i <= other_len; ++i) {
+ SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
+ SV * const * const other_elem = av_fetch(other_av, i, FALSE);
+
+ if (!this_elem || !other_elem) {
+ if (this_elem || other_elem)
+ RETPUSHNO;
+ }
+ else if (SM_SEEN_THIS(*this_elem)
+ || SM_SEEN_OTHER(*other_elem))
+ {
+ if (*this_elem != *other_elem)
+ RETPUSHNO;
+ }
+ else {
+ hv_store_ent(seen_this,
+ sv_2mortal(newSViv(PTR2IV(*this_elem))),
+ &PL_sv_undef, 0);
+ hv_store_ent(seen_other,
+ sv_2mortal(newSViv(PTR2IV(*other_elem))),
+ &PL_sv_undef, 0);
+ PUSHs(*this_elem);
+ PUSHs(*other_elem);
+
+ PUTBACK;
+ (void) do_smartmatch(seen_this, seen_other);
+ SPAGAIN;
+
+ if (!SvTRUEx(POPs))
+ RETPUSHNO;
+ }
+ }
+ RETPUSHYES;
+ }
+ }
+ else if (SM_OTHER_REGEX) {
+ PMOP * const matcher = make_matcher(other_regex);
+ const I32 this_len = av_len((AV *) This);
+ I32 i;
+
+ for(i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ if (svp && matcher_matches_sv(matcher, *svp)) {
+ destroy_matcher(matcher);
+ RETPUSHYES;
+ }
+ }
+ destroy_matcher(matcher);
+ RETPUSHNO;
+ }
+ else if (SvIOK(Other) || SvNOK(Other)) {
+ I32 i;
+
+ for(i = 0; i <= AvFILL((AV *) This); ++i) {
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ if (!svp)
+ continue;
+
+ PUSHs(Other);
+ PUSHs(*svp);
+ PUTBACK;
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
+ (void) pp_i_eq();
+ else
+ (void) pp_eq();
+ SPAGAIN;
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ else if (SvPOK(Other)) {
+ const I32 this_len = av_len((AV *) This);
+ I32 i;
+
+ for(i = 0; i <= this_len; ++i) {
+ SV * const * const svp = av_fetch((AV *)This, i, FALSE);
+ if (!svp)
+ continue;
+
+ PUSHs(Other);
+ PUSHs(*svp);
+ PUTBACK;
+ (void) pp_seq();
+ SPAGAIN;
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ }
+ else if (!SvOK(d) || !SvOK(e)) {
+ if (!SvOK(d) && !SvOK(e))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+ else if (SM_REGEX) {
+ PMOP * const matcher = make_matcher(this_regex);
+
+ PUTBACK;
+ PUSHs(matcher_matches_sv(matcher, Other)
+ ? &PL_sv_yes
+ : &PL_sv_no);
+ destroy_matcher(matcher);
+ RETURN;
+ }
+ else if (SM_REF(PVCV)) {
+ I32 c;
+ /* This must be a null-prototyped sub, because we
+ already checked for the other kind. */
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ PUTBACK;
+ c = call_sv(This, G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_undef);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc_void(TOPs);
+
+ if (SM_OTHER_REF(PVCV)) {
+ /* This one has to be null-proto'd too.
+ Call both of 'em, and compare the results */
+ PUSHMARK(SP);
+ c = call_sv(SvRV(Other), G_SCALAR);
+ SPAGAIN;
+ if (c == 0)
+ PUSHs(&PL_sv_undef);
+ else if (SvTEMP(TOPs))
+ SvREFCNT_inc_void(TOPs);
+ FREETMPS;
+ LEAVE;
+ PUTBACK;
+ return pp_eq();
+ }
+
+ FREETMPS;
+ LEAVE;
+ RETURN;
+ }
+ else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
+ || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
+ {
+ if (SvPOK(Other) && !looks_like_number(Other)) {
+ /* String comparison */
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ return pp_seq();
+ }
+ /* Otherwise, numeric comparison */
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
+ (void) pp_i_eq();
+ else
+ (void) pp_eq();
+ SPAGAIN;
+ if (SvTRUEx(POPs))
+ RETPUSHYES;
+ else
+ RETPUSHNO;
+ }
+
+ /* As a last resort, use string comparison */
+ PUSHs(d); PUSHs(e);
+ PUTBACK;
+ return pp_seq();
+}
+
+PP(pp_enterwhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
+ /* This is essentially an optimization: if the match
+ fails, we don't want to push a context and then
+ pop it again right away, so we skip straight
+ to the op that follows the leavewhen.
+ */
+ if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
+ return cLOGOP->op_other->op_next;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHBLOCK(cx, CXt_WHEN, SP);
+ PUSHWHEN(cx);
+
+ RETURN;
+}
+
+PP(pp_leavewhen)
+{
+ dVAR; dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+
+ POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_WHEN);
+
+ SP = newsp;
+ PUTBACK;
+
+ PL_curpm = newpm; /* pop $1 et al */
+
+ LEAVE;
+ return NORMAL;
+}
+
+PP(pp_continue)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptowhen(cxstack_ix);
+ if (cxix < 0)
+ DIE(aTHX_ "Can't \"continue\" outside a when block");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+ return cx->blk_givwhen.leave_op;
+}
+
+PP(pp_break)
+{
+ dVAR;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 inner;
+
+ cxix = dopoptogiven(cxstack_ix);
+ if (cxix < 0) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ DIE(aTHX_ "Can't use when() outside a topicalizer");
+ else
+ DIE(aTHX_ "Can't \"break\" outside a given block");
+ }
+ if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+ DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ /* clear off anything above the scope we're re-entering */
+ inner = PL_scopestack_ix;
+ TOPBLOCK(cx);
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
+
+ if (CxFOREACH(cx))
+ return CX_LOOP_NEXTOP_GET(cx);
+ else
+ return cx->blk_givwhen.leave_op;
}
STATIC OP *
{
STRLEN len;
register char *s = SvPV_force(sv, len);
- register char *send = s + len;
- register char *base = Nullch;
+ register char * const send = s + len;
+ register char *base = NULL;
register I32 skipspaces = 0;
bool noblank = FALSE;
bool repeat = FALSE;
bool postspace = FALSE;
U32 *fops;
register U32 *fpc;
- U32 *linepc = 0;
+ U32 *linepc = NULL;
register I32 arg;
bool ischop;
bool unchopnum = FALSE;
maxops += 10;
}
s = base;
- base = Nullch;
+ base = NULL;
- New(804, fops, maxops, U32);
+ Newx(fops, maxops, U32);
fpc = fops;
if (s < send) {
while (*s == '#')
s++;
if (*s == '.') {
- char *f;
- s++;
- f = s;
+ const char * const f = ++s;
while (*s == '#')
s++;
arg |= 256 + (s - f);
while (*s == '#')
s++;
if (*s == '.') {
- char *f;
- s++;
- f = s;
+ const char * const f = ++s;
while (*s == '#')
s++;
arg |= 256 + (s - f);
}
Copy(fops, s, arg, U32);
Safefree(fops);
- sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
+ sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
SvCOMPILED_on(sv);
- if (unchopnum && repeat)
+ if (unchopnum && repeat)
DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
return 0;
}
}
static I32
-run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
+S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- SV *datasv = FILTER_DATA(idx);
- int filter_has_file = IoLINES(datasv);
- GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
- SV *filter_state = (SV *)IoTOP_GV(datasv);
- SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
- int len = 0;
+ dVAR;
+ SV * const datasv = FILTER_DATA(idx);
+ const int filter_has_file = IoLINES(datasv);
+ SV * const filter_state = (SV *)IoTOP_GV(datasv);
+ SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
+ int status = 0;
+ SV *upstream;
+ STRLEN got_len;
+ const char *got_p = NULL;
+ const char *prune_from = NULL;
+ bool read_from_cache = FALSE;
+ STRLEN umaxlen;
+
+ assert(maxlen >= 0);
+ umaxlen = maxlen;
/* I was having segfault trouble under Linux 2.2.5 after a
parse error occured. (Had to hack around it with a test
for PL_error_count == 0.) Solaris doesn't segfault --
not sure where the trouble is yet. XXX */
+ if (IoFMT_GV(datasv)) {
+ SV *const cache = (SV *)IoFMT_GV(datasv);
+ if (SvOK(cache)) {
+ STRLEN cache_len;
+ const char *cache_p = SvPV(cache, cache_len);
+ STRLEN take = 0;
+
+ if (umaxlen) {
+ /* Running in block mode and we have some cached data already.
+ */
+ if (cache_len >= umaxlen) {
+ /* In fact, so much data we don't even need to call
+ filter_read. */
+ take = umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(cache_p, '\n', cache_len);
+ if (first_nl) {
+ take = first_nl + 1 - cache_p;
+ }
+ }
+ if (take) {
+ sv_catpvn(buf_sv, cache_p, take);
+ sv_chop(cache, cache_p + take);
+ /* Definately not EOF */
+ return 1;
+ }
+
+ sv_catsv(buf_sv, cache);
+ if (umaxlen) {
+ umaxlen -= cache_len;
+ }
+ SvOK_off(cache);
+ read_from_cache = TRUE;
+ }
+ }
+
+ /* Filter API says that the filter appends to the contents of the buffer.
+ Usually the buffer is "", so the details don't matter. But if it's not,
+ then clearly what it contains is already filtered by this filter, so we
+ don't want to pass it in a second time.
+ I'm going to use a mortal in case the upstream filter croaks. */
+ upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
+ ? sv_newmortal() : buf_sv;
+ SvUPGRADE(upstream, SVt_PV);
+
if (filter_has_file) {
- len = FILTER_READ(idx+1, buf_sv, maxlen);
+ status = FILTER_READ(idx+1, upstream, 0);
}
- if (filter_sub && len >= 0) {
+ if (filter_sub && status >= 0) {
dSP;
int count;
SAVETMPS;
EXTEND(SP, 2);
- DEFSV = buf_sv;
+ DEFSV = upstream;
PUSHMARK(SP);
- PUSHs(sv_2mortal(newSViv(maxlen)));
+ PUSHs(sv_2mortal(newSViv(0)));
if (filter_state) {
PUSHs(filter_state);
}
if (count > 0) {
SV *out = POPs;
if (SvOK(out)) {
- len = SvIV(out);
+ status = SvIV(out);
}
}
LEAVE;
}
- if (len <= 0) {
- IoLINES(datasv) = 0;
- if (filter_child_proc) {
- SvREFCNT_dec(filter_child_proc);
- IoFMT_GV(datasv) = Nullgv;
+ if(SvOK(upstream)) {
+ got_p = SvPV(upstream, got_len);
+ if (umaxlen) {
+ if (got_len > umaxlen) {
+ prune_from = got_p + umaxlen;
+ }
+ } else {
+ const char *const first_nl =
+ (const char *)memchr(got_p, '\n', got_len);
+ if (first_nl && first_nl + 1 < got_p + got_len) {
+ /* There's a second line here... */
+ prune_from = first_nl + 1;
+ }
+ }
+ }
+ if (prune_from) {
+ /* Oh. Too long. Stuff some in our cache. */
+ STRLEN cached_len = got_p + got_len - prune_from;
+ SV *cache = (SV *)IoFMT_GV(datasv);
+
+ if (!cache) {
+ IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
+ } else if (SvOK(cache)) {
+ /* Cache should be empty. */
+ assert(!SvCUR(cache));
+ }
+
+ sv_setpvn(cache, prune_from, cached_len);
+ /* If you ask for block mode, you may well split UTF-8 characters.
+ "If it breaks, you get to keep both parts"
+ (Your code is broken if you don't put them back together again
+ before something notices.) */
+ if (SvUTF8(upstream)) {
+ SvUTF8_on(cache);
}
+ SvCUR_set(upstream, got_len - cached_len);
+ /* Can't yet be EOF */
+ if (status == 0)
+ status = 1;
+ }
+
+ /* If they are at EOF but buf_sv has something in it, then they may never
+ have touched the SV upstream, so it may be undefined. If we naively
+ concatenate it then we get a warning about use of uninitialised value.
+ */
+ if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
+ sv_catsv(buf_sv, upstream);
+ }
+
+ if (status <= 0) {
+ IoLINES(datasv) = 0;
+ SvREFCNT_dec(IoFMT_GV(datasv));
if (filter_state) {
SvREFCNT_dec(filter_state);
- IoTOP_GV(datasv) = Nullgv;
+ IoTOP_GV(datasv) = NULL;
}
if (filter_sub) {
SvREFCNT_dec(filter_sub);
- IoBOTTOM_GV(datasv) = Nullgv;
+ IoBOTTOM_GV(datasv) = NULL;
}
- filter_del(run_user_filter);
+ filter_del(S_run_user_filter);
}
-
- return len;
+ if (status == 0 && read_from_cache) {
+ /* If we read some data from the cache (and by getting here it implies
+ that we emptied the cache) then we aren't yet at EOF, and mustn't
+ report that to our caller. */
+ return 1;
+ }
+ return status;
}
/* perhaps someone can come up with a better name for
this? it is not really "absolute", per se ... */
static bool
-S_path_is_absolute(pTHX_ char *name)
+S_path_is_absolute(const char *name)
{
if (PERL_FILE_IS_ABSOLUTE(name)
#ifdef MACOS_TRADITIONAL
- || (*name == ':'))
+ || (*name == ':')
#else
|| (*name == '.' && (name[1] == '/' ||
- (name[1] == '.' && name[2] == '/'))))
+ (name[1] == '.' && name[2] == '/')))
#endif
+ )
{
return TRUE;
}
else
return FALSE;
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff