X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e682d7b7fae5a50c5afb147f913a4e88d7261606..12e82c57598512160891396c5760944e2e0d31c5:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 0c1067a..cda9811 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,7 +1,7 @@ /* 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. @@ -17,6 +17,17 @@ * 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" @@ -27,10 +38,9 @@ #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); @@ -49,13 +59,9 @@ PP(pp_wantarray) } } -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; @@ -65,42 +71,69 @@ PP(pp_regcreset) 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. */ @@ -113,7 +146,7 @@ PP(pp_regcomp) 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 @@ -150,42 +183,44 @@ PP(pp_regcomp) 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) { @@ -196,23 +231,20 @@ PP(pp_substcont) } 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))); @@ -223,7 +255,6 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); - ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -238,21 +269,25 @@ PP(pp_substcont) } 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)) @@ -260,7 +295,7 @@ PP(pp_substcont) 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); @@ -271,26 +306,27 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) { 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; @@ -308,12 +344,13 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { 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); @@ -333,47 +370,54 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 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)) { @@ -392,15 +436,13 @@ PP(pp_formline) 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; @@ -420,7 +462,7 @@ PP(pp_formline) 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) @@ -438,14 +480,14 @@ PP(pp_formline) 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); @@ -475,127 +517,134 @@ PP(pp_formline) 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; @@ -617,77 +666,81 @@ PP(pp_formline) 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; @@ -696,62 +749,70 @@ PP(pp_formline) 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, @@ -765,7 +826,7 @@ PP(pp_formline) gotsome = TRUE; value = SvNV(sv); /* overflow evidence */ - if (num_overflow(value, fieldsize, arg)) { + if (num_overflow(value, fieldsize, arg)) { arg = fieldsize; while (arg--) *t++ = '#'; @@ -774,7 +835,7 @@ PP(pp_formline) /* 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; @@ -792,7 +853,7 @@ PP(pp_formline) 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; @@ -813,33 +874,35 @@ PP(pp_formline) 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; @@ -851,7 +914,7 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + dVAR; dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -886,15 +949,10 @@ PP(pp_grepstart) 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; @@ -931,7 +989,7 @@ PP(pp_mapwhile) * irrelevant. --jhi */ if (shift < count) shift = count; /* Avoid shifting too often --Ben Tilly */ - + EXTEND(SP,shift); src = SP; dst = (SP += shift); @@ -946,7 +1004,7 @@ PP(pp_mapwhile) 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. */ @@ -1004,6 +1062,7 @@ PP(pp_mapwhile) PP(pp_range) { + dVAR; if (GIMME == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) @@ -1014,6 +1073,7 @@ PP(pp_range) PP(pp_flip) { + dVAR; dSP; if (GIMME == G_ARRAY) { @@ -1021,21 +1081,22 @@ PP(pp_flip) } 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); @@ -1048,7 +1109,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpv(TARG, ""); + sv_setpvn(TARG, "", 0); SETs(targ); RETURN; } @@ -1062,25 +1123,22 @@ PP(pp_flip) 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"); @@ -1094,20 +1152,20 @@ PP(pp_flop) 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); @@ -1116,7 +1174,7 @@ PP(pp_flop) } 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); @@ -1125,7 +1183,7 @@ PP(pp_flop) 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)); } } @@ -1135,7 +1193,7 @@ PP(pp_flop) 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); } @@ -1145,30 +1203,34 @@ PP(pp_flop) /* 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)); @@ -1176,8 +1238,7 @@ S_dopoptolabel(pTHX_ char *label) 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; @@ -1189,19 +1250,21 @@ S_dopoptolabel(pTHX_ char *label) 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; @@ -1222,9 +1285,8 @@ Perl_block_gimme(pTHX) 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)) @@ -1236,16 +1298,17 @@ Perl_is_lvalue_sub(pTHX) 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; @@ -1262,10 +1325,10 @@ S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) 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; @@ -1280,10 +1343,10 @@ S_dopoptoeval(pTHX_ I32 startingblock) 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: @@ -1304,15 +1367,56 @@ S_dopoptoloop(pTHX_ I32 startingblock) 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. */ @@ -1338,51 +1442,52 @@ Perl_dounwind(pTHX_ I32 cxix) } 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); } } } @@ -1400,6 +1505,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (cxix >= 0) { I32 optype; + register PERL_CONTEXT *cx; + SV **newsp; if (cxix < cxstack_ix) dounwind(cxix); @@ -1407,8 +1514,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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); } @@ -1427,18 +1534,19 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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(); @@ -1448,75 +1556,23 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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) @@ -1536,7 +1592,8 @@ PP(pp_caller) } 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--) @@ -1546,10 +1603,11 @@ PP(pp_caller) 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]; } @@ -1566,7 +1624,7 @@ PP(pp_caller) RETURN; } - EXTEND(SP, 10); + EXTEND(SP, 11); if (!stashname) PUSHs(&PL_sv_undef); @@ -1577,21 +1635,21 @@ PP(pp_caller) 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; @@ -1623,13 +1681,12 @@ PP(pp_caller) 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) */ } @@ -1642,11 +1699,10 @@ PP(pp_caller) /* 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)) @@ -1656,8 +1712,8 @@ PP(pp_caller) /* 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 { @@ -1665,36 +1721,33 @@ PP(pp_caller) } } 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; @@ -1704,14 +1757,12 @@ PP(pp_dbstate) || 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"); @@ -1728,29 +1779,36 @@ PP(pp_dbstate) 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 @@ -1774,15 +1832,18 @@ PP(pp_enteriter) #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); @@ -1795,24 +1856,29 @@ PP(pp_enteriter) 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; } } @@ -1820,8 +1886,8 @@ PP(pp_enteriter) 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; @@ -1833,9 +1899,9 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; ENTER; SAVETMPS; @@ -1849,7 +1915,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1857,12 +1923,13 @@ PP(pp_leaveloop) 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); @@ -1889,8 +1956,7 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; - I32 cxix; + dVAR; dSP; dMARK; register PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; @@ -1899,35 +1965,48 @@ PP(pp_return) 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(); @@ -1935,13 +2014,14 @@ PP(pp_return) (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"); @@ -1989,18 +2069,18 @@ PP(pp_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; @@ -2010,7 +2090,8 @@ PP(pp_last) SV **newsp; PMOP *newpm; SV **mark; - SV *sv = Nullsv; + SV *sv = NULL; + if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -2032,19 +2113,19 @@ PP(pp_last) 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"); @@ -2083,11 +2164,14 @@ PP(pp_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; @@ -2111,14 +2195,17 @@ PP(pp_next) 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); @@ -2133,19 +2220,28 @@ PP(pp_redo) 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); @@ -2161,6 +2257,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) } *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) && @@ -2187,29 +2284,20 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) 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) { @@ -2219,12 +2307,13 @@ PP(pp_goto) 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))) @@ -2234,14 +2323,14 @@ PP(pp_goto) 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) @@ -2249,40 +2338,44 @@ PP(pp_goto) 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); @@ -2291,43 +2384,28 @@ PP(pp_goto) /* 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; indexblk_eval.old_in_eval; PL_eval_root = cx->blk_eval.old_eval_root; @@ -2335,44 +2413,49 @@ PP(pp_goto) 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); @@ -2384,30 +2467,31 @@ PP(pp_goto) * 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); } @@ -2420,14 +2504,14 @@ PP(pp_goto) 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]; @@ -2455,7 +2539,7 @@ PP(pp_goto) 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; } @@ -2507,7 +2591,7 @@ PP(pp_goto) /* 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]; @@ -2539,6 +2623,7 @@ PP(pp_goto) PP(pp_exit) { + dVAR; dSP; I32 anum; @@ -2553,64 +2638,29 @@ PP(pp_exit) #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'); @@ -2625,28 +2675,20 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } -#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 @@ -2654,37 +2696,32 @@ S_docatch(pTHX_ OP *o) #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; @@ -2694,19 +2731,20 @@ S_docatch(pTHX_ OP *o) } 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; @@ -2714,7 +2752,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) 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); @@ -2726,14 +2765,16 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) 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); @@ -2743,8 +2784,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) (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; @@ -2761,7 +2802,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) 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); @@ -2774,13 +2815,16 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) (*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; } @@ -2792,7 +2836,7 @@ Locate the CV corresponding to the currently executing sub or eval. If db_seqp is non_null, skip CVs that are in the DB package and populate *db_seqp with the cop sequence number at the point that the DB:: code was entered. (allows debuggers to eval in the scope of the breakpoint rather -than in in the scope of the debugger itself). +than in the scope of the debugger itself). =cut */ @@ -2800,17 +2844,17 @@ than in in the scope of the debugger itself). 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; @@ -2836,8 +2880,8 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) 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)) @@ -2846,21 +2890,23 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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 */ @@ -2873,57 +2919,60 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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); @@ -2950,8 +2999,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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); @@ -2972,134 +3021,99 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } 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 */ @@ -3120,16 +3134,16 @@ PP(pp_require) } #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; @@ -3143,8 +3157,8 @@ PP(pp_require) 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; @@ -3167,34 +3181,32 @@ PP(pp_require) 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) { @@ -3204,17 +3216,17 @@ PP(pp_require) 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--; } @@ -3229,17 +3241,17 @@ PP(pp_require) } 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 { @@ -3251,7 +3263,7 @@ PP(pp_require) || (*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]; @@ -3259,24 +3271,41 @@ PP(pp_require) 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; } } } @@ -3287,26 +3316,32 @@ PP(pp_require) 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); } @@ -3317,48 +3352,49 @@ PP(pp_require) 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); @@ -3367,27 +3403,23 @@ PP(pp_require) /* 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; @@ -3395,8 +3427,16 @@ PP(pp_entereval) 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"); @@ -3407,14 +3447,15 @@ PP(pp_entereval) /* 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); @@ -3424,23 +3465,22 @@ PP(pp_entereval) (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 @@ -3449,9 +3489,9 @@ PP(pp_entereval) * 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 */ @@ -3461,26 +3501,27 @@ PP(pp_entereval) 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) @@ -3520,58 +3561,92 @@ PP(pp_leaveeval) !(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)) @@ -3587,6 +3662,7 @@ PP(pp_leavetry) } 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); @@ -3597,8 +3673,581 @@ PP(pp_leavetry) 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 * @@ -3606,15 +4255,15 @@ S_doparseform(pTHX_ SV *sv) { STRLEN len; register char *s = SvPV_force(sv, len); - register char *send = s + len; - register char *base = Nullch; + register char * const send = s + len; + register char *base = NULL; register I32 skipspaces = 0; bool noblank = FALSE; bool repeat = FALSE; bool postspace = FALSE; U32 *fops; register U32 *fpc; - U32 *linepc = 0; + U32 *linepc = NULL; register I32 arg; bool ischop; bool unchopnum = FALSE; @@ -3629,9 +4278,9 @@ S_doparseform(pTHX_ SV *sv) maxops += 10; } s = base; - base = Nullch; + base = NULL; - New(804, fops, maxops, U32); + Newx(fops, maxops, U32); fpc = fops; if (s < send) { @@ -3732,9 +4381,7 @@ S_doparseform(pTHX_ SV *sv) while (*s == '#') s++; if (*s == '.') { - char *f; - s++; - f = s; + const char * const f = ++s; while (*s == '#') s++; arg |= 256 + (s - f); @@ -3751,9 +4398,7 @@ S_doparseform(pTHX_ SV *sv) while (*s == '#') s++; if (*s == '.') { - char *f; - s++; - f = s; + const char * const f = ++s; while (*s == '#') s++; arg |= 256 + (s - f); @@ -3814,10 +4459,10 @@ S_doparseform(pTHX_ SV *sv) } 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; } @@ -3851,25 +4496,81 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) } 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; @@ -3878,9 +4579,9 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) 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); } @@ -3891,7 +4592,7 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (count > 0) { SV *out = POPs; if (SvOK(out)) { - len = SvIV(out); + status = SvIV(out); } } @@ -3900,41 +4601,103 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) 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: + */