/* pp_ctl.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * Now far ahead the Road has gone, * And I must follow, if I can, * Pursuing it with eager feet, * Until it joins some larger way * Where many paths and errands meet. * And whither then? I cannot say. */ /* 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" #ifndef WORD_ALIGN #define WORD_ALIGN sizeof(U32) #endif #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) 74262 { 74262 dSP; 74262 I32 cxix; 74262 EXTEND(SP, 1); 74262 cxix = dopoptosub(cxstack_ix); 74262 if (cxix < 0) 2 RETPUSHUNDEF; 74260 switch (cxstack[cxix].blk_gimme) { case G_ARRAY: 33817 RETPUSHYES; case G_SCALAR: 28067 RETPUSHNO; default: 12376 RETPUSHUNDEF; } } PP(pp_regcmaybe) ###### { ###### return NORMAL; } PP(pp_regcreset) 4085412 { /* XXXX Should store the old value to allow for tie/overload - and restore in regcomp, where marked with XXXX. */ 4085412 PL_reginterp_cnt = 0; 4085412 TAINT_NOT; 4085412 return NORMAL; } PP(pp_regcomp) 4059727 { 4059727 dSP; 4059727 register PMOP *pm = (PMOP*)cLOGOP->op_other; 4059727 SV *tmpstr; 4059727 MAGIC *mg = Null(MAGIC*); /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { if (PL_op->op_flags & OPf_STACKED) { dMARK; SP = MARK; } else (void)POPs; RETURN; } #endif 4059727 if (PL_op->op_flags & OPf_STACKED) { /* multiple args; concatentate them */ 453176 dMARK; dORIGMARK; 453176 tmpstr = PAD_SV(ARGTARG); 453176 sv_setpvn(tmpstr, "", 0); 2154721 while (++MARK <= SP) { 1701545 if (PL_amagic_generation) { 1701545 SV *sv; 1701545 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) && (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign))) { 6 sv_setsv(tmpstr, sv); 6 continue; } } 1701539 sv_catsv(tmpstr, *MARK); } 453176 SvSETMAGIC(tmpstr); 453176 SP = ORIGMARK; } else 3606551 tmpstr = POPs; 4059727 if (SvROK(tmpstr)) { 1892691 SV *sv = SvRV(tmpstr); 1892691 if(SvMAGICAL(sv)) 1892687 mg = mg_find(sv, PERL_MAGIC_qr); } 4059727 if (mg) { 1892687 regexp *re = (regexp *)mg->mg_obj; 1892687 ReREFCNT_dec(PM_GETRE(pm)); 1892687 PM_SETRE(pm, ReREFCNT_inc(re)); } else { 2167040 STRLEN len; 2167040 const char *t = SvPV_const(tmpstr, len); /* Check against the last compiled regexp. */ 2167040 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || PM_GETRE(pm)->prelen != (I32)len || memNE(PM_GETRE(pm)->precomp, t, len)) { 1779079 if (PM_GETRE(pm)) { 1774460 ReREFCNT_dec(PM_GETRE(pm)); 1774460 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ } 1779079 if (PL_op->op_flags & OPf_SPECIAL) 64 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ 1779079 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ 1779079 if (DO_UTF8(tmpstr)) 7940 pm->op_pmdynflags |= PMdf_DYN_UTF8; else { 1771139 pm->op_pmdynflags &= ~PMdf_DYN_UTF8; 1771139 if (pm->op_pmdynflags & PMdf_UTF8) ###### t = (char*)bytes_to_utf8((U8*)t, &len); } 1779079 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm)); 1778029 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) ###### Safefree(t); 1778029 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } } #ifndef INCOMPLETE_TAINTS 4058677 if (PL_tainting) { 3409607 if (PL_tainted) 848234 pm->op_pmdynflags |= PMdf_TAINTED; else 2561373 pm->op_pmdynflags &= ~PMdf_TAINTED; } #endif 4058677 if (!PM_GETRE(pm)->prelen && PL_curpm) 17 pm = PL_curpm; 4058660 else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 1 pm->op_pmflags |= PMf_WHITE; else 4058659 pm->op_pmflags &= ~PMf_WHITE; /* XXX runtime compiled output needs to move to the pad */ 4058677 if (pm->op_pmflags & PMf_KEEP) { 643 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ #if !defined(USE_ITHREADS) /* XXX can't change the optree at runtime either */ 643 cLOGOP->op_first->op_next = PL_op->op_next; #endif } 4058677 RETURN; } PP(pp_substcont) 646518 { 646518 dSP; 646518 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 646518 register PMOP * const pm = (PMOP*) cLOGOP->op_other; 646518 register SV * const dstr = cx->sb_dstr; 646518 register char *s = cx->sb_s; 646518 register char *m = cx->sb_m; 646518 char *orig = cx->sb_orig; 646518 register REGEXP * const rx = cx->sb_rx; 646518 SV *nsv = Nullsv; 646518 REGEXP *old = PM_GETRE(pm); 646518 if(old != rx) { 4 if(old) 4 ReREFCNT_dec(old); 4 PM_SETRE(pm,rx); } 646518 rxres_restore(&cx->sb_rxres, rx); 646518 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); 646518 if (cx->sb_iters++) { 430470 const I32 saviters = cx->sb_iters; 430470 if (cx->sb_iters > cx->sb_maxiters) ###### DIE(aTHX_ "Substitution loop"); 430470 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) 4 cx->sb_rxtainted |= 2; 430470 sv_catsv(dstr, POPs); /* Are we done */ 430470 if (cx->sb_once || !CALLREGEXEC(aTHX_ 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)))) { 216046 SV *targ = cx->sb_targ; 216046 assert(cx->sb_strend >= s); 216046 if(cx->sb_strend > s) { 174060 if (DO_UTF8(dstr) && !SvUTF8(targ)) 3 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); else 174057 sv_catpvn(dstr, s, cx->sb_strend - s); } 216046 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(targ)) { sv_force_normal_flags(targ, SV_COW_DROP_PV); } else #endif { 216046 SvPV_free(targ); } 216046 SvPV_set(targ, SvPVX(dstr)); 216046 SvCUR_set(targ, SvCUR(dstr)); 216046 SvLEN_set(targ, SvLEN(dstr)); 216046 if (DO_UTF8(dstr)) 93 SvUTF8_on(targ); 216046 SvPV_set(dstr, (char*)0); 216046 sv_free(dstr); 216046 TAINT_IF(cx->sb_rxtainted & 1); 216046 PUSHs(sv_2mortal(newSViv(saviters - 1))); 216046 (void)SvPOK_only_UTF8(targ); 216046 TAINT_IF(cx->sb_rxtainted); 216046 SvSETMAGIC(targ); 216046 SvTAINT(targ); 216046 LEAVE_SCOPE(cx->sb_oldsave); 216046 ReREFCNT_dec(rx); 216046 POPSUBST(cx); 216046 RETURNOP(pm->op_next); } 214424 cx->sb_iters = saviters; } 430472 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 215063 m = s; 215063 s = orig; 215063 cx->sb_orig = orig = rx->subbeg; 215063 s = orig + (m - s); 215063 cx->sb_strend = s + (cx->sb_strend - m); } 430472 cx->sb_m = m = rx->startp[0] + orig; 430472 if (m > s) { 173323 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) 3 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else 173320 sv_catpvn(dstr, s, m-s); } 430472 cx->sb_s = rx->endp[0] + orig; { /* Update the pos() information. */ 430472 SV *sv = cx->sb_targ; 430472 MAGIC *mg; 430472 I32 i; 430472 if (SvTYPE(sv) < SVt_PVMG) 11650 SvUPGRADE(sv, SVt_PVMG); 430472 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { 79285 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); 79285 mg = mg_find(sv, PERL_MAGIC_regex_global); } 430472 i = m - orig; 430472 if (DO_UTF8(sv)) 1043 sv_pos_b2u(sv, &i); 430472 mg->mg_len = i; } 430472 if (old != rx) 4 (void)ReREFCNT_inc(rx); 430472 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 430472 rxres_save(&cx->sb_rxres, rx); 430472 RETURNOP(pm->op_pmreplstart); } void Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 646520 { 646520 UV *p = (UV*)*rsp; 646520 U32 i; 646520 if (!p || p[1] < rx->nparens) { #ifdef PERL_OLD_COPY_ON_WRITE i = 7 + rx->nparens * 2; #else 216048 i = 6 + rx->nparens * 2; #endif 216048 if (!p) 216048 New(501, p, i, UV); else ###### Renew(p, i, UV); 216048 *rsp = (void*)p; } 646520 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); 646520 RX_MATCH_COPIED_off(rx); #ifdef PERL_OLD_COPY_ON_WRITE *p++ = PTR2UV(rx->saved_copy); rx->saved_copy = Nullsv; #endif 646520 *p++ = rx->nparens; 646520 *p++ = PTR2UV(rx->subbeg); 646520 *p++ = (UV)rx->sublen; 2335240 for (i = 0; i <= rx->nparens; ++i) { 1688720 *p++ = (UV)rx->startp[i]; 1688720 *p++ = (UV)rx->endp[i]; } } void Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 646518 { 646518 UV *p = (UV*)*rsp; 646518 U32 i; 646518 RX_MATCH_COPY_FREE(rx); 646518 RX_MATCH_COPIED_set(rx, *p); 646518 *p++ = 0; #ifdef PERL_OLD_COPY_ON_WRITE if (rx->saved_copy) SvREFCNT_dec (rx->saved_copy); rx->saved_copy = INT2PTR(SV*,*p); *p++ = 0; #endif 646518 rx->nparens = *p++; 646518 rx->subbeg = INT2PTR(char*,*p++); 646518 rx->sublen = (I32)(*p++); 2335236 for (i = 0; i <= rx->nparens; ++i) { 1688718 rx->startp[i] = (I32)(*p++); 1688718 rx->endp[i] = (I32)(*p++); } } void Perl_rxres_free(pTHX_ void **rsp) 216048 { 216048 UV *p = (UV*)*rsp; 216048 if (p) { #ifdef PERL_POISON void *tmp = INT2PTR(char*,*p); Safefree(tmp); if (*p) Poison(*p, 1, sizeof(*p)); #else 216048 Safefree(INT2PTR(char*,*p)); #endif #ifdef PERL_OLD_COPY_ON_WRITE if (p[1]) { SvREFCNT_dec (INT2PTR(SV*,p[1])); } #endif 216048 Safefree(p); 216048 *rsp = Null(void*); } } PP(pp_formline) 326 { 326 dSP; dMARK; dORIGMARK; 326 register SV *tmpForm = *++MARK; 326 register U32 *fpc; 326 register char *t; 326 const char *f; 326 register I32 arg; 326 register SV *sv = Nullsv; 326 const char *item = Nullch; 326 I32 itemsize = 0; 326 I32 fieldsize = 0; 326 I32 lines = 0; 326 bool chopspace = (strchr(PL_chopset, ' ') != Nullch); 326 const char *chophere = Nullch; 326 char *linemark = Nullch; 326 NV value; 326 bool gotsome = FALSE; 326 STRLEN len; 326 STRLEN fudge = SvPOK(tmpForm) 326 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; 326 bool item_is_utf8 = FALSE; 326 bool targ_is_utf8 = FALSE; 326 SV * nsv = Nullsv; 326 OP * parseres = 0; 326 const char *fmt; 326 bool oneline; 326 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { 121 if (SvREADONLY(tmpForm)) { 68 SvREADONLY_off(tmpForm); 68 parseres = doparseform(tmpForm); 67 SvREADONLY_on(tmpForm); } else 53 parseres = doparseform(tmpForm); 119 if (parseres) ###### return parseres; } 324 SvPV_force(PL_formtarget, len); 324 if (DO_UTF8(PL_formtarget)) 11 targ_is_utf8 = TRUE; 324 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ 324 t += len; 324 f = SvPV_const(tmpForm, len); /* need to jump to the next word */ 324 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); 2735 for (;;) { DEBUG_f( { const char *name = "???"; arg = -1; switch (*fpc) { case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; case FF_CHECKNL: name = "CHECKNL"; break; case FF_CHECKCHOP: name = "CHECKCHOP"; break; case FF_SPACE: name = "SPACE"; break; case FF_HALFSPACE: name = "HALFSPACE"; break; case FF_ITEM: name = "ITEM"; break; case FF_CHOP: name = "CHOP"; break; case FF_LINEGLOB: name = "LINEGLOB"; break; case FF_NEWLINE: name = "NEWLINE"; break; case FF_MORE: name = "MORE"; break; case FF_LINEMARK: name = "LINEMARK"; break; case FF_END: name = "END"; break; case FF_0DECIMAL: name = "0DECIMAL"; break; case FF_LINESNGL: name = "LINESNGL"; break; } if (arg >= 0) PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); else PerlIO_printf(Perl_debug_log, "%-16s\n", name); 2411 } ); 2411 switch (*fpc++) { case FF_LINEMARK: 352 linemark = t; 352 lines++; 352 gotsome = FALSE; 352 break; case FF_LITERAL: 236 arg = *fpc++; 236 if (targ_is_utf8 && !SvUTF8(tmpForm)) { 5 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 5 *t = '\0'; 5 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); 5 t = SvEND(PL_formtarget); 5 break; } 231 if (!targ_is_utf8 && DO_UTF8(tmpForm)) { ###### SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); ###### *t = '\0'; ###### sv_utf8_upgrade(PL_formtarget); ###### SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); ###### t = SvEND(PL_formtarget); ###### targ_is_utf8 = TRUE; } 1521 while (arg--) 1290 *t++ = *f++; 98 break; case FF_SKIP: 98 f += *fpc++; 98 break; case FF_FETCH: 294 arg = *fpc++; 294 f += arg; 294 fieldsize = arg; 294 if (MARK < SP) 290 sv = *++MARK; else { 4 sv = &PL_sv_no; 4 if (ckWARN(WARN_SYNTAX)) 1 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); } 1 break; case FF_CHECKNL: { 107 const char *send; 107 const char *s = item = SvPV_const(sv, len); 107 itemsize = len; 107 if (DO_UTF8(sv)) { 2 itemsize = sv_len_utf8(sv); 2 if (itemsize != (I32)len) { 2 I32 itembytes; 2 if (itemsize > fieldsize) { ###### itemsize = fieldsize; ###### itembytes = itemsize; ###### sv_pos_u2b(sv, &itembytes, 0); } else 2 itembytes = len; 2 send = chophere = s + itembytes; 6 while (s < send) { 4 if (*s & ~31) 4 gotsome = TRUE; ###### else if (*s == '\n') ###### break; 4 s++; } 2 item_is_utf8 = TRUE; 2 itemsize = s - item; 2 sv_pos_b2u(sv, &itemsize); 2 break; } } 105 item_is_utf8 = FALSE; 105 if (itemsize > fieldsize) 9 itemsize = fieldsize; 105 send = chophere = s + itemsize; 378 while (s < send) { 276 if (*s & ~31) 273 gotsome = TRUE; 3 else if (*s == '\n') 3 break; 273 s++; } 105 itemsize = s - item; 105 break; } case FF_CHECKCHOP: { 137 const char *s = item = SvPV_const(sv, len); 137 itemsize = len; 137 if (DO_UTF8(sv)) { ###### itemsize = sv_len_utf8(sv); ###### if (itemsize != (I32)len) { ###### I32 itembytes; ###### if (itemsize <= fieldsize) { ###### const char *send = chophere = s + itemsize; ###### while (s < send) { ###### if (*s == '\r') { ###### itemsize = s - item; ###### chophere = s; ###### break; } ###### if (*s++ & ~31) ###### gotsome = TRUE; } } else { ###### const char *send; ###### itemsize = fieldsize; ###### itembytes = itemsize; ###### sv_pos_u2b(sv, &itembytes, 0); ###### send = chophere = s + itembytes; ###### while (s < send || (s == send && isSPACE(*s))) { ###### if (isSPACE(*s)) { ###### if (chopspace) ###### chophere = s; ###### if (*s == '\r') ###### break; } else { ###### if (*s & ~31) ###### gotsome = TRUE; ###### if (strchr(PL_chopset, *s)) ###### chophere = s + 1; } ###### s++; } ###### itemsize = chophere - item; ###### sv_pos_b2u(sv, &itemsize); } ###### item_is_utf8 = TRUE; ###### break; } } 137 item_is_utf8 = FALSE; 137 if (itemsize <= fieldsize) { 93 const char *const send = chophere = s + itemsize; 1442 while (s < send) { 1350 if (*s == '\r') { 1 itemsize = s - item; 1 chophere = s; 1 break; } 1349 if (*s++ & ~31) 1349 gotsome = TRUE; } } else { 44 const char *send; 44 itemsize = fieldsize; 44 send = chophere = s + itemsize; 1693 while (s < send || (s == send && isSPACE(*s))) { 1649 if (isSPACE(*s)) { 205 if (chopspace) 205 chophere = s; 205 if (*s == '\r') ###### break; } else { 1444 if (*s & ~31) 1444 gotsome = TRUE; 1444 if (strchr(PL_chopset, *s)) 6 chophere = s + 1; } 1649 s++; } 44 itemsize = chophere - item; } 44 break; } case FF_SPACE: 68 arg = fieldsize - itemsize; 68 if (arg) { 47 fieldsize -= arg; 200 while (arg-- > 0) 153 *t++ = ' '; } 5 break; case FF_HALFSPACE: 5 arg = fieldsize - itemsize; 5 if (arg) { 5 arg /= 2; 5 fieldsize -= arg; 8 while (arg-- > 0) 3 *t++ = ' '; } 244 break; case FF_ITEM: { 244 const char *s = item; 244 arg = itemsize; 244 if (item_is_utf8) { 2 if (!targ_is_utf8) { 1 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 1 *t = '\0'; 1 sv_utf8_upgrade(PL_formtarget); 1 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 1 t = SvEND(PL_formtarget); 1 targ_is_utf8 = TRUE; } 4 while (arg--) { 2 if (UTF8_IS_CONTINUED(*s)) { 2 STRLEN skip = UTF8SKIP(s); 2 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++; 2 case 2: *t++ = *s++; 2 case 1: *t++ = *s++; } } else { ###### if ( !((*t++ = *s++) & ~31) ) ###### t[-1] = ' '; } } 242 break; } 242 if (targ_is_utf8 && !item_is_utf8) { 6 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 6 *t = '\0'; 6 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); 30 for (; t < SvEND(PL_formtarget); t++) { #ifdef EBCDIC const int ch = *t; if (iscntrl(ch)) #else 12 if (!(*t & ~31)) #endif ###### *t = ' '; } 236 break; } 3367 while (arg--) { #ifdef EBCDIC const int ch = *t++ = *s++; if (iscntrl(ch)) #else 3131 if ( !((*t++ = *s++) & ~31) ) #endif ###### t[-1] = ' '; } 137 break; } case FF_CHOP: { 137 const char *s = chophere; 137 if (chopspace) { 183 while (*s && isSPACE(*s)) 46 s++; } 137 sv_chop(sv,s); 137 SvSETMAGIC(sv); 2 break; } case FF_LINESNGL: ###### chopspace = 0; ###### oneline = TRUE; ###### goto ff_line; case FF_LINEGLOB: 16 oneline = FALSE; ff_line: { 16 const char *s = item = SvPV_const(sv, len); 16 itemsize = len; 16 if ((item_is_utf8 = DO_UTF8(sv))) 1 itemsize = sv_len_utf8(sv); 16 if (itemsize) { 11 bool chopped = FALSE; 11 const char *const send = s + len; 11 gotsome = TRUE; 11 chophere = s + itemsize; 166 while (s < send) { 155 if (*s++ == '\n') { 23 if (oneline) { ###### chopped = TRUE; ###### chophere = s; ###### break; } else { 23 if (s == send) { 11 itemsize--; 11 chopped = TRUE; } else 12 lines++; } } } 11 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 11 if (targ_is_utf8) 2 SvUTF8_on(PL_formtarget); 11 if (oneline) { ###### SvCUR_set(sv, chophere - item); ###### sv_catsv(PL_formtarget, sv); ###### SvCUR_set(sv, itemsize); } else 11 sv_catsv(PL_formtarget, sv); 11 if (chopped) 11 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); 11 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 11 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); 11 if (item_is_utf8) 1 targ_is_utf8 = TRUE; } 1 break; } case FF_0DECIMAL: 14 arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; #else 14 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; #endif 14 goto ff_dec; case FF_DECIMAL: 20 arg = *fpc++; #if defined(USE_LONG_DOUBLE) fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; #else 20 fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; #endif ff_dec: /* If the field is marked with ^ and the value is undefined, blank it out. */ 34 if ((arg & 512) && !SvOK(sv)) { 2 arg = fieldsize; 10 while (arg--) 8 *t++ = ' '; 32 break; } 32 gotsome = TRUE; 32 value = SvNV(sv); /* overflow evidence */ 32 if (num_overflow(value, fieldsize, arg)) { 10 arg = fieldsize; 56 while (arg--) 46 *t++ = '#'; 22 break; } /* Formats aren't yet marked for locales, so assume "yes". */ { 22 STORE_NUMERIC_STANDARD_SET_LOCAL(); 22 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); 22 RESTORE_NUMERIC_STANDARD(); } 22 t += fieldsize; 22 break; case FF_NEWLINE: 299 f++; 545 while (t-- > linemark && *t == ' ') ; 299 t++; 299 *t++ = '\n'; 299 break; case FF_BLANK: 133 arg = *fpc++; 133 if (gotsome) { 80 if (arg) { /* repeat until fields exhausted? */ 75 *t = '\0'; 75 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 75 lines += FmLINES(PL_formtarget); 75 if (lines == 200) { ###### arg = t - linemark; ###### if (strnEQ(linemark, linemark - arg, arg)) ###### DIE(aTHX_ "Runaway format"); } 75 if (targ_is_utf8) ###### SvUTF8_on(PL_formtarget); 75 FmLINES(PL_formtarget) = lines; 75 SP = ORIGMARK; 75 RETURNOP(cLISTOP->op_first); } } else { 53 t = linemark; 53 lines--; } 53 break; case FF_MORE: { 2 const char *s = chophere; 2 const char *send = item + len; 2 if (chopspace) { 6 while (*s && isSPACE(*s) && s < send) 4 s++; } 2 if (s < send) { 1 char *s1; 1 arg = fieldsize - itemsize; 1 if (arg) { 1 fieldsize -= arg; 3 while (arg-- > 0) 2 *t++ = ' '; } 1 s1 = t - 3; 1 if (strnEQ(s1," ",3)) { ###### while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) ###### s1--; } 1 *s1++ = '.'; 1 *s1++ = '.'; 1 *s1++ = '.'; } 1 break; } case FF_END: 249 *t = '\0'; 249 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 249 if (targ_is_utf8) 12 SvUTF8_on(PL_formtarget); 249 FmLINES(PL_formtarget) += lines; 249 SP = ORIGMARK; 249 RETPUSHYES; } } } PP(pp_grepstart) 971296 { 971296 dVAR; dSP; 971296 SV *src; 971296 if (PL_stack_base + *PL_markstack_ptr == SP) { 12364 (void)POPMARK; 12364 if (GIMME_V == G_SCALAR) 379 XPUSHs(sv_2mortal(newSViv(0))); 12364 RETURNOP(PL_op->op_next->op_next); } 958932 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; 958932 pp_pushmark(); /* push dst */ 958932 pp_pushmark(); /* push src */ 958932 ENTER; /* enter outer scope */ 958932 SAVETMPS; 958932 if (PL_op->op_private & OPpGREP_LEX) 6 SAVESPTR(PAD_SVl(PL_op->op_targ)); else 958926 SAVE_DEFSV; 958932 ENTER; /* enter inner scope */ 958932 SAVEVPTR(PL_curpm); 958932 src = PL_stack_base[*PL_markstack_ptr]; 958932 SvTEMP_off(src); 958932 if (PL_op->op_private & OPpGREP_LEX) 6 PAD_SVl(PL_op->op_targ) = src; else 958926 DEFSV = src; 958932 PUTBACK; 958932 if (PL_op->op_type == OP_MAPSTART) 912577 pp_pushmark(); /* push top */ 958932 return ((LOGOP*)PL_op->op_next)->op_other; } PP(pp_mapstart) ###### { ###### DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ } PP(pp_mapwhile) 2545081 { 2545081 dVAR; dSP; 2545081 const I32 gimme = GIMME_V; 2545081 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ 2545081 I32 count; 2545081 I32 shift; 2545081 SV** src; 2545081 SV** dst; /* first, move source pointer to the next item in the source list */ 2545081 ++PL_markstack_ptr[-1]; /* if there are new items, push them into the destination list */ 2545081 if (items && gimme != G_VOID) { /* might need to make room back there first */ 2541407 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { /* XXX this implementation is very pessimal because the stack * is repeatedly extended for every set of items. Is possible * to do this without any stack extension or copying at all * by maintaining a separate list over which the map iterates * (like foreach does). --gsar */ /* everything in the stack after the destination list moves * towards the end the stack by the amount of room needed */ 8327 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); /* items to shift up (accounting for the moved source pointer) */ 8327 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); /* This optimization is by Ben Tilly and it does * things differently from what Sarathy (gsar) * is describing. The downside of this optimization is * that leaves "holes" (uninitialized and hopefully unused areas) * to the Perl stack, but on the other hand this * shouldn't be a problem. If Sarathy's idea gets * implemented, this optimization should become * irrelevant. --jhi */ 8327 if (shift < count) 8327 shift = count; /* Avoid shifting too often --Ben Tilly */ 8327 EXTEND(SP,shift); 8327 src = SP; 8327 dst = (SP += shift); 8327 PL_markstack_ptr[-1] += shift; 8327 *PL_markstack_ptr += shift; 87478 while (count--) 79151 *dst-- = *src--; } /* copy the new items down to the destination list */ 2541407 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 2541407 if (gimme == G_ARRAY) { 5152121 while (items-- > 0) 2611126 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); } 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. */ 834 while (items-- > 0) { 422 (void)POPs; 422 *dst-- = &PL_sv_undef; } } } 2545081 LEAVE; /* exit inner scope */ /* All done yet? */ 2545081 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { 912560 (void)POPMARK; /* pop top */ 912560 LEAVE; /* exit outer scope */ 912560 (void)POPMARK; /* pop src */ 912560 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 912560 (void)POPMARK; /* pop dst */ 912560 SP = PL_stack_base + POPMARK; /* pop original mark */ 912560 if (gimme == G_SCALAR) { 53 if (PL_op->op_private & OPpGREP_LEX) { 1 SV* sv = sv_newmortal(); 1 sv_setiv(sv, items); 1 PUSHs(sv); } else { 52 dTARGET; 52 XPUSHi(items); } } 912507 else if (gimme == G_ARRAY) 912378 SP += items; 912560 RETURN; } else { 1632521 SV *src; 1632521 ENTER; /* enter inner scope */ 1632521 SAVEVPTR(PL_curpm); /* set $_ to the new source item */ 1632521 src = PL_stack_base[PL_markstack_ptr[-1]]; 1632521 SvTEMP_off(src); 1632521 if (PL_op->op_private & OPpGREP_LEX) 3 PAD_SVl(PL_op->op_targ) = src; else 1632518 DEFSV = src; 1632521 RETURNOP(cLOGOP->op_other); } } /* Range stuff. */ PP(pp_range) 8510 { 8510 if (GIMME == G_ARRAY) 8053 return NORMAL; 457 if (SvTRUEx(PAD_SV(PL_op->op_targ))) 102 return cLOGOP->op_other; else 355 return NORMAL; } PP(pp_flip) 8408 { 8408 dSP; 8408 if (GIMME == G_ARRAY) { 8053 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } else { 355 dTOPss; 355 SV *targ = PAD_SV(PL_op->op_targ); 355 int flip = 0; 355 if (PL_op->op_private & OPpFLIP_LINENUM) { 283 if (GvIO(PL_last_in_gv)) { 277 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); } else { 6 GV *gv = gv_fetchpv(".", TRUE, SVt_PV); 6 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv)); } } else { 72 flip = SvTRUE(sv); } 355 if (flip) { 36 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 36 if (PL_op->op_flags & OPf_SPECIAL) { 11 sv_setiv(targ, 1); 11 SETs(targ); 11 RETURN; } else { 25 sv_setiv(targ, 0); 25 SP--; 25 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } 319 sv_setpvn(TARG, "", 0); 319 SETs(targ); 319 RETURN; } } /* This code tries to decide if "$left .. $right" should use the magical string increment, or if the range is numeric (we make an exception for .."0" [#18165]). AMS 20021031. */ #define RANGE_IS_NUMERIC(left,right) ( \ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ && (!SvOK(right) || looks_like_number(right)))) PP(pp_flop) 8180 { 8180 dSP; 8180 if (GIMME == G_ARRAY) { 8053 dPOPPOPssrl; 8053 if (SvGMAGICAL(left)) 1 mg_get(left); 8053 if (SvGMAGICAL(right)) 294 mg_get(right); 8053 if (RANGE_IS_NUMERIC(left,right)) { 8004 register IV i, j; 8004 IV max; 8004 if ((SvOK(left) && SvNV(left) < IV_MIN) || (SvOK(right) && SvNV(right) > IV_MAX)) ###### DIE(aTHX_ "Range iterator outside integer range"); 8004 i = SvIV(left); 8004 max = SvIV(right); 8004 if (max >= i) { 7904 j = max - i + 1; 7904 EXTEND_MORTAL(j); 7904 EXTEND(SP, j); } else 100 j = 0; 768868 while (j--) { 760864 SV * const sv = sv_2mortal(newSViv(i++)); 760864 PUSHs(sv); } } else { 49 SV *final = sv_mortalcopy(right); 49 STRLEN len; 49 const char *tmps = SvPV_const(final, len); 49 SV *sv = sv_mortalcopy(left); 49 SvPV_force_nolen(sv); 19571 while (!SvNIOKp(sv) && SvCUR(sv) <= len) { 19566 XPUSHs(sv); 19566 if (strEQ(SvPVX_const(sv),tmps)) 44 break; 19522 sv = sv_2mortal(newSVsv(sv)); 19522 sv_inc(sv); } } } else { 127 dTOPss; 127 SV * const targ = PAD_SV(cUNOP->op_first->op_targ); 127 int flop = 0; 127 sv_inc(targ); 127 if (PL_op->op_private & OPpFLIP_LINENUM) { 47 if (GvIO(PL_last_in_gv)) { 43 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); } else { 4 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV); 4 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); } } else { 80 flop = SvTRUE(sv); } 127 if (flop) { 30 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 30 sv_catpvn(targ, "E0", 2); } 127 SETs(targ); } 8180 RETURN; } /* Control. */ static const char * const context_name[] = { "pseudo-block", "subroutine", "eval", "loop", "substitution", "block", "format" }; STATIC I32 S_dopoptolabel(pTHX_ const char *label) 32951 { 32951 register I32 i; 97165 for (i = cxstack_ix; i >= 0; i--) { 97165 register const PERL_CONTEXT * const cx = &cxstack[i]; 97165 switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: 232 if (ckWARN(WARN_EXITING)) 4 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); 232 if (CxTYPE(cx) == CXt_NULL) 2 return -1; 58514 break; case CXt_LOOP: 58514 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", 25565 (long)i, cx->blk_loop.label)); ###### continue; } 32949 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); 32949 return i; } } ###### return i; } I32 Perl_dowantarray(pTHX) 68917 { 68917 const I32 gimme = block_gimme(); 68917 return (gimme == G_VOID) ? G_SCALAR : gimme; } I32 Perl_block_gimme(pTHX) 1810414 { 1810414 const I32 cxix = dopoptosub(cxstack_ix); 1810414 if (cxix < 0) 562 return G_VOID; 1809852 switch (cxstack[cxix].blk_gimme) { case G_VOID: 1074740 return G_VOID; case G_SCALAR: 434043 return G_SCALAR; case G_ARRAY: 301069 return G_ARRAY; default: ###### Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); /* NOTREACHED */ 1810414 return 0; } } I32 Perl_is_lvalue_sub(pTHX) 34 { 34 const I32 cxix = dopoptosub(cxstack_ix); 34 assert(cxix >= 0); /* We should only be called from inside subs */ 34 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) 30 return cxstack[cxix].blk_sub.lval; else 4 return 0; } STATIC I32 S_dopoptosub(pTHX_ I32 startingblock) 11039132 { 11039132 return dopoptosub_at(cxstack, startingblock); } STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) 11312131 { 11312131 I32 i; 12994953 for (i = startingblock; i >= 0; i--) { 12943586 register const PERL_CONTEXT * const cx = &cxstk[i]; 12943586 switch (CxTYPE(cx)) { default: 1682822 continue; case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: 11260764 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); 11260764 return i; } } 51367 return i; } STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) 4424 { 4424 I32 i; 7890 for (i = startingblock; i >= 0; i--) { 7811 register const PERL_CONTEXT *cx = &cxstack[i]; 7811 switch (CxTYPE(cx)) { default: 3466 continue; case CXt_EVAL: 4345 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); 4345 return i; } } 79 return i; } STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) 520330 { 520330 I32 i; 689638 for (i = startingblock; i >= 0; i--) { 689635 register const PERL_CONTEXT * const cx = &cxstack[i]; 689635 switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: 13 if (ckWARN(WARN_EXITING)) 4 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); 13 if ((CxTYPE(cx)) == CXt_NULL) 2 return -1; 520325 break; case CXt_LOOP: 520325 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); 520325 return i; } } 3 return i; } void Perl_dounwind(pTHX_ I32 cxix) 913660 { 913660 I32 optype; 2422168 while (cxstack_ix > cxix) { 1508508 SV *sv; 1508508 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", 1508508 (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); /* Note: we don't need to restore the base context info till the end. */ 1508508 switch (CxTYPE(cx)) { case CXt_SUBST: 2 POPSUBST(cx); 2 continue; /* not break */ case CXt_SUB: 3314 POPSUB(cx,sv); 3314 LEAVESUB(sv); ###### break; case CXt_EVAL: 10 POPEVAL(cx); ###### break; case CXt_LOOP: 561215 POPLOOP(cx); ###### break; case CXt_NULL: 1 break; case CXt_FORMAT: 1 POPFORMAT(cx); break; } 1508506 cxstack_ix--; } 913660 PERL_UNUSED_VAR(optype); } void Perl_qerror(pTHX_ SV *err) 285 { 285 if (PL_in_eval) 232 sv_catsv(ERRSV, err); 53 else if (PL_errors) 53 sv_catsv(PL_errors, err); else ###### Perl_warn(aTHX_ "%"SVf, err); 285 ++PL_error_count; } OP * Perl_die_where(pTHX_ const char *message, STRLEN msglen) 4411 { dVAR; 4411 if (PL_in_eval) { 4345 I32 cxix; 4345 I32 gimme; 4345 if (message) { 4336 if (PL_in_eval & EVAL_KEEPERR) { 73 static const char prefix[] = "\t(in cleanup) "; 73 SV *err = ERRSV; 73 const char *e = Nullch; 73 if (!SvPOK(err)) ###### sv_setpvn(err,"",0); 73 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { 39 STRLEN len; 39 e = SvPV_const(err, len); 39 e += len - msglen; 39 if (*e != *message || strNE(e,message)) 3 e = Nullch; } 73 if (!e) { 37 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); 37 sv_catpvn(err, prefix, sizeof(prefix)-1); 37 sv_catpvn(err, message, msglen); 37 if (ckWARN(WARN_MISC)) { 2 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; 2 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); } } } else { 4263 sv_setpvn(ERRSV, message, msglen); } } 4424 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { 79 dounwind(-1); 79 POPSTACK; } 4345 if (cxix >= 0) { 4345 I32 optype; 4345 register PERL_CONTEXT *cx; 4345 SV **newsp; 4345 if (cxix < cxstack_ix) 1189 dounwind(cxix); 4345 POPBLOCK(cx,PL_curpm); 4345 if (CxTYPE(cx) != CXt_EVAL) { ###### if (!message) ###### message = SvPVx_const(ERRSV, msglen); ###### PerlIO_write(Perl_error_log, "panic: die ", 11); ###### PerlIO_write(Perl_error_log, message, msglen); ###### my_exit(1); } 4345 POPEVAL(cx); 4345 if (gimme == G_SCALAR) 2559 *++newsp = &PL_sv_undef; 4345 PL_stack_sp = newsp; 4345 LEAVE; /* LEAVE could clobber PL_curcop (see save_re_context()) * XXX it might be better to find a way to avoid messing with * PL_curcop in save_re_context() instead, but this is a more * minimal fix --GSAR */ 4345 PL_curcop = cx->blk_oldcop; 4345 if (optype == OP_REQUIRE) { 25 const char* msg = SvPVx_nolen_const(ERRSV); 25 SV * const nsv = cx->blk_eval.old_namesv; 25 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); 25 DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } 4320 assert(CxTYPE(cx) == CXt_EVAL); 4320 return cx->blk_eval.retop; } } 66 if (!message) 1 message = SvPVx_const(ERRSV, msglen); 66 write_to_stderr(message, msglen); 66 my_failure_exit(); /* NOTREACHED */ 4320 return 0; } PP(pp_xor) 55167 { 55167 dSP; dPOPTOPssrl; 55167 if (SvTRUE(left) != SvTRUE(right)) 47418 RETSETYES; else 7749 RETSETNO; } PP(pp_andassign) 99 { 99 dSP; 99 if (!SvTRUE(TOPs)) 5 RETURN; else 94 RETURNOP(cLOGOP->op_other); } PP(pp_orassign) 2534049 { 2534049 dSP; 2534049 if (SvTRUE(TOPs)) 1377882 RETURN; else 1156167 RETURNOP(cLOGOP->op_other); } PP(pp_dorassign) 9 { 9 dSP; 9 register SV* sv; 9 sv = TOPs; 9 if (!sv || !SvANY(sv)) { 1 RETURNOP(cLOGOP->op_other); } 8 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; 8 break; default: 8 if (SvGMAGICAL(sv)) ###### mg_get(sv); 8 if (SvOK(sv)) 4 RETURN; } 4 RETURNOP(cLOGOP->op_other); } PP(pp_caller) 127723 { 127723 dSP; 127723 register I32 cxix = dopoptosub(cxstack_ix); 127723 register const PERL_CONTEXT *cx; 127723 register const PERL_CONTEXT *ccstack = cxstack; 127723 const PERL_SI *top_si = PL_curstackinfo; 127723 I32 gimme; 127723 const char *stashname; 127723 I32 count = 0; 127723 if (MAXARG) 112458 count = POPi; 420104 for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ 276856 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { 5885 top_si = top_si->si_prev; 5885 ccstack = top_si->si_cxstack; 5885 cxix = dopoptosub_at(ccstack, top_si->si_cxix); } 270971 if (cxix < 0) { 1298 if (GIMME != G_ARRAY) { 57 EXTEND(SP, 1); 57 RETPUSHUNDEF; } 1241 RETURN; } /* caller() should not report the automatic calls to &DB::sub */ 269673 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) ###### count++; 269673 if (!count--) 126425 break; 143248 cxix = dopoptosub_at(ccstack, cxix - 1); } 126425 cx = &ccstack[cxix]; 126425 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 123866 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ /* caller() should not report the automatic calls to &DB::sub */ 123866 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) ###### cx = &ccstack[dbcxix]; } 126425 stashname = CopSTASHPV(cx->blk_oldcop); 126425 if (GIMME != G_ARRAY) { 39300 EXTEND(SP, 1); 39300 if (!stashname) ###### PUSHs(&PL_sv_undef); else { 39300 dTARGET; 39300 sv_setpv(TARG, stashname); 39300 PUSHs(TARG); } 39300 RETURN; } 87125 EXTEND(SP, 10); 87125 if (!stashname) ###### PUSHs(&PL_sv_undef); else 87125 PUSHs(sv_2mortal(newSVpv(stashname, 0))); 87125 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); 87125 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); 87125 if (!MAXARG) 2534 RETURN; 84591 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 82697 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); /* So is ccstack[dbcxix]. */ 82697 if (isGV(cvgv)) { 82695 SV * const sv = NEWSV(49, 0); 82695 gv_efullname3(sv, cvgv, Nullch); 82695 PUSHs(sv_2mortal(sv)); 82695 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); } else { 2 PUSHs(sv_2mortal(newSVpvn("(unknown)",9))); 2 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); } } else { 1894 PUSHs(sv_2mortal(newSVpvn("(eval)",6))); 1894 PUSHs(sv_2mortal(newSViv(0))); } 84591 gimme = (I32)cx->blk_gimme; 84591 if (gimme == G_VOID) 54477 PUSHs(&PL_sv_undef); else 30114 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); 84591 if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ 1894 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { 431 PUSHs(cx->blk_eval.cur_text); 431 PUSHs(&PL_sv_no); } /* require */ 1463 else if (cx->blk_eval.old_namesv) { 294 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); 294 PUSHs(&PL_sv_yes); } /* eval BLOCK (try blocks have old_namesv == 0) */ else { 1169 PUSHs(&PL_sv_undef); 1169 PUSHs(&PL_sv_undef); } } else { 82697 PUSHs(&PL_sv_undef); 82697 PUSHs(&PL_sv_undef); } 84591 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs && CopSTASH_eq(PL_curcop, PL_debstash)) { 844 AV * const ary = cx->blk_sub.argarray; 844 const int off = AvARRAY(ary) - AvALLOC(ary); 844 if (!PL_dbargs) { 190 GV* tmpgv; 190 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); 190 GvMULTI_on(tmpgv); 190 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } 844 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) 226 av_extend(PL_dbargs, AvFILLp(ary) + off); 844 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); 844 AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } /* XXX only hints propagated via op_private are currently * visible (others are not easily accessible, since they * use the global PL_hints) */ PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & 84591 HINT_PRIVATE_MASK))); { 84591 SV * mask ; 84591 SV * old_warnings = cx->blk_oldcop->cop_warnings ; 84591 if (old_warnings == pWARN_NONE || (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) 27546 mask = newSVpvn(WARN_NONEstring, WARNsize) ; 57045 else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ 43252 SV **bits_all; 43252 HV *bits = get_hv("warnings::Bits", FALSE); 43252 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { 42323 mask = newSVsv(*bits_all); } else { 929 mask = newSVpvn(WARN_ALLstring, WARNsize) ; } } else 13793 mask = newSVsv(old_warnings); 84591 PUSHs(sv_2mortal(mask)); } 84591 RETURN; } PP(pp_reset) 13 { 13 dSP; 13 const char *tmps; 13 if (MAXARG < 1) 8 tmps = ""; else 5 tmps = POPpconstx; 13 sv_reset(tmps, CopSTASH(PL_curcop)); 13 PUSHs(&PL_sv_yes); 13 RETURN; } PP(pp_lineseq) ###### { ###### return NORMAL; } /* like pp_nextstate, but used instead when the debugger is active */ PP(pp_dbstate) 160316 { dVAR; 160316 PL_curcop = (COP*)PL_op; 160316 TAINT_NOT; /* Each statement is presumed innocent */ 160316 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 160316 FREETMPS; 160316 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { 7 dSP; 7 register CV *cv; 7 register PERL_CONTEXT *cx; 7 const I32 gimme = G_ARRAY; 7 U8 hasargs; 7 GV *gv; 7 gv = PL_DBgv; 7 cv = GvCV(gv); 7 if (!cv) ###### DIE(aTHX_ "No DB::DB routine defined"); 7 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) /* don't do recursive DB::DB call */ ###### return NORMAL; 7 ENTER; 7 SAVETMPS; 7 SAVEI32(PL_debug); 7 SAVESTACK_POS(); 7 PL_debug = 0; 7 hasargs = 0; 7 SPAGAIN; 7 PUSHBLOCK(cx, CXt_SUB, SP); 7 PUSHSUB_DB(cx); 7 cx->blk_sub.retop = PL_op->op_next; 7 CvDEPTH(cv)++; 7 SAVECOMPPAD(); 7 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); 7 RETURNOP(CvSTART(cv)); } else 160309 return NORMAL; } PP(pp_scope) 3245349 { 3245349 return NORMAL; } PP(pp_enteriter) 821621 { 821621 dVAR; dSP; dMARK; 821621 register PERL_CONTEXT *cx; 821621 const I32 gimme = GIMME_V; 821621 SV **svp; 821621 U32 cxtype = CXt_LOOP; #ifdef USE_ITHREADS void *iterdata; #endif 821621 ENTER; 821621 SAVETMPS; 821621 if (PL_op->op_targ) { 539341 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ 418925 SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), 418925 SVs_PADSTALE, SVs_PADSTALE); } #ifndef USE_ITHREADS 539341 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ 539341 SAVESPTR(*svp); #else SAVEPADSV(PL_op->op_targ); iterdata = INT2PTR(void*, PL_op->op_targ); cxtype |= CXp_PADVAR; #endif } else { 282280 GV *gv = (GV*)POPs; 282280 svp = &GvSV(gv); /* symbol table variable */ 282280 SAVEGENERICSV(*svp); 282280 *svp = NEWSV(0,0); #ifdef USE_ITHREADS iterdata = (void*)gv; #endif } 821621 ENTER; 821621 PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS PUSHLOOP(cx, iterdata, MARK); #else 821621 PUSHLOOP(cx, svp, MARK); #endif 821621 if (PL_op->op_flags & OPf_STACKED) { 465540 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); 465540 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { 18870 dPOPss; 18870 SV *right = (SV*)cx->blk_loop.iterary; 18870 if (RANGE_IS_NUMERIC(sv,right)) { 18863 if ((SvOK(sv) && SvNV(sv) < IV_MIN) || (SvOK(right) && SvNV(right) >= IV_MAX)) ###### DIE(aTHX_ "Range iterator outside integer range"); 18863 cx->blk_loop.iterix = SvIV(sv); 18863 cx->blk_loop.itermax = SvIV(right); } else { 7 cx->blk_loop.iterlval = newSVsv(sv); 7 (void) SvPV_force_nolen(cx->blk_loop.iterlval); 7 (void) SvPV_nolen_const(right); } } 446670 else if (PL_op->op_private & OPpITER_REVERSED) { 2705 cx->blk_loop.itermax = -1; 2705 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary); } } else { 356081 cx->blk_loop.iterary = PL_curstack; 356081 AvFILLp(PL_curstack) = SP - PL_stack_base; 356081 if (PL_op->op_private & OPpITER_REVERSED) { 33 cx->blk_loop.itermax = MARK - PL_stack_base; 33 cx->blk_loop.iterix = cx->blk_oldsp; } else { 356048 cx->blk_loop.iterix = MARK - PL_stack_base; } } 821621 RETURN; } PP(pp_enterloop) 1679914 { 1679914 dVAR; dSP; 1679914 register PERL_CONTEXT *cx; 1679914 const I32 gimme = GIMME_V; 1679914 ENTER; 1679914 SAVETMPS; 1679914 ENTER; 1679914 PUSHBLOCK(cx, CXt_LOOP, SP); 1679914 PUSHLOOP(cx, 0, SP); 1679914 RETURN; } PP(pp_leaveloop) 1853593 { 1853593 dVAR; dSP; 1853593 register PERL_CONTEXT *cx; 1853593 I32 gimme; 1853593 SV **newsp; 1853593 PMOP *newpm; 1853593 SV **mark; 1853593 POPBLOCK(cx,newpm); 1853593 assert(CxTYPE(cx) == CXt_LOOP); 1853593 mark = newsp; 1853593 newsp = PL_stack_base + cx->blk_loop.resetsp; 1853593 TAINT_NOT; 1853593 if (gimme == G_VOID) ; /* do nothing */ 798420 else if (gimme == G_SCALAR) { 2988 if (mark < SP) 2988 *++newsp = sv_mortalcopy(*SP); else ###### *++newsp = &PL_sv_undef; } else { 1501117 while (mark < SP) { 705685 *++newsp = sv_mortalcopy(*++mark); 705685 TAINT_NOT; /* Each item is independent */ } } 1853593 SP = newsp; 1853593 PUTBACK; 1853593 POPLOOP(cx); /* Stack values are safe: release loop vars ... */ 1853593 PL_curpm = newpm; /* ... and pop $1 et al */ 1853593 LEAVE; 1853593 LEAVE; 1853593 return NORMAL; } PP(pp_return) 9020105 { 9020105 dVAR; dSP; dMARK; 9020105 I32 cxix; 9020105 register PERL_CONTEXT *cx; 9020105 bool popsub2 = FALSE; 9020105 bool clear_errsv = FALSE; 9020105 I32 gimme; 9020105 SV **newsp; 9020105 PMOP *newpm; 9020105 I32 optype = 0; 9020105 SV *sv; 9020105 OP *retop; 9020105 if (PL_curstackinfo->si_type == PERLSI_SORT) { 1558 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) { 1556 if (cxstack_ix > PL_sortcxix) 192 dounwind(PL_sortcxix); 1556 AvARRAY(PL_curstack)[1] = *SP; 1556 PL_stack_sp = PL_stack_base + 1; 1556 return 0; } } 9018549 cxix = dopoptosub(cxstack_ix); 9018549 if (cxix < 0) ###### DIE(aTHX_ "Can't return outside a subroutine"); 9018549 if (cxix < cxstack_ix) 721148 dounwind(cxix); 9018549 POPBLOCK(cx,newpm); 9018549 switch (CxTYPE(cx)) { case CXt_SUB: 9013670 popsub2 = TRUE; 9013670 retop = cx->blk_sub.retop; 9013670 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ 9013670 break; case CXt_EVAL: 4879 if (!(PL_in_eval & EVAL_KEEPERR)) 4879 clear_errsv = TRUE; 4879 POPEVAL(cx); 4879 retop = cx->blk_eval.retop; 4879 if (CxTRYBLOCK(cx)) 3 break; 4876 lex_end(); 4876 if (optype == OP_REQUIRE && 1 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) { /* Unassume the success we assumed earlier. */ ###### SV * const nsv = cx->blk_eval.old_namesv; ###### (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); ###### DIE(aTHX_ "%"SVf" did not return a true value", nsv); } ###### break; case CXt_FORMAT: ###### POPFORMAT(cx); ###### retop = cx->blk_sub.retop; ###### break; default: ###### DIE(aTHX_ "panic: return"); } 9018549 TAINT_NOT; 9018549 if (gimme == G_SCALAR) { 7369407 if (MARK < SP) { 7331492 if (popsub2) { 7326618 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 5321352 if (SvTEMP(TOPs)) { 3063 *++newsp = SvREFCNT_inc(*SP); 3063 FREETMPS; 3063 sv_2mortal(*newsp); } else { 5318289 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ 5318289 FREETMPS; 5318289 *++newsp = sv_mortalcopy(sv); 5318289 SvREFCNT_dec(sv); } } else 2005266 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); } else 4874 *++newsp = sv_mortalcopy(*SP); } else 37915 *++newsp = &PL_sv_undef; } 1649142 else if (gimme == G_ARRAY) { 2307984 while (++MARK <= SP) { 1317349 *++newsp = (popsub2 && SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); 1317349 TAINT_NOT; /* Each item is independent */ } } 9018549 PL_stack_sp = newsp; 9018549 LEAVE; /* Stack values are safe: */ 9018549 if (popsub2) { 9013670 cxstack_ix--; 9013670 POPSUB(cx,sv); /* release CV and @_ ... */ } else 4879 sv = Nullsv; 9018549 PL_curpm = newpm; /* ... and pop $1 et al */ 9018549 LEAVESUB(sv); 9018549 if (clear_errsv) 4879 sv_setpvn(ERRSV,"",0); 9018549 return retop; } PP(pp_last) 86734 { 86734 dVAR; dSP; 86734 I32 cxix; 86734 register PERL_CONTEXT *cx; 86734 I32 pop2 = 0; 86734 I32 gimme; 86734 I32 optype; 86734 OP *nextop; 86734 SV **newsp; 86734 PMOP *newpm; 86734 SV **mark; 86734 SV *sv = Nullsv; 86734 if (PL_op->op_flags & OPf_SPECIAL) { 56665 cxix = dopoptoloop(cxstack_ix); 56665 if (cxix < 0) 2 DIE(aTHX_ "Can't \"last\" outside a loop block"); } else { 30069 cxix = dopoptolabel(cPVOP->op_pv); 30069 if (cxix < 0) 2 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); } 86730 if (cxix < cxstack_ix) 59830 dounwind(cxix); 86730 POPBLOCK(cx,newpm); 86730 cxstack_ix++; /* temporarily protect top context */ 86730 mark = newsp; 86730 switch (CxTYPE(cx)) { case CXt_LOOP: 86730 pop2 = CXt_LOOP; 86730 newsp = PL_stack_base + cx->blk_loop.resetsp; 86730 nextop = cx->blk_loop.last_op->op_next; 86730 break; case CXt_SUB: ###### pop2 = CXt_SUB; ###### nextop = cx->blk_sub.retop; ###### break; case CXt_EVAL: ###### POPEVAL(cx); ###### nextop = cx->blk_eval.retop; ###### break; case CXt_FORMAT: ###### POPFORMAT(cx); ###### nextop = cx->blk_sub.retop; ###### break; default: ###### DIE(aTHX_ "panic: last"); } 86730 TAINT_NOT; 86730 if (gimme == G_SCALAR) { 17 if (MARK < SP) ###### *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); else 17 *++newsp = &PL_sv_undef; } 86713 else if (gimme == G_ARRAY) { 21852 while (++MARK <= SP) { ###### *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); ###### TAINT_NOT; /* Each item is independent */ } } 86730 SP = newsp; 86730 PUTBACK; 86730 LEAVE; 86730 cxstack_ix--; /* Stack values are safe: */ 86730 switch (pop2) { case CXt_LOOP: 86730 POPLOOP(cx); /* release loop vars ... */ 86730 LEAVE; 86730 break; case CXt_SUB: ###### POPSUB(cx,sv); /* release CV and @_ ... */ break; } 86730 PL_curpm = newpm; /* ... and pop $1 et al */ 86730 LEAVESUB(sv); 86730 PERL_UNUSED_VAR(optype); 86730 PERL_UNUSED_VAR(gimme); 86730 return nextop; } PP(pp_next) 463334 { dVAR; 463334 I32 cxix; 463334 register PERL_CONTEXT *cx; 463334 I32 inner; 463334 if (PL_op->op_flags & OPf_SPECIAL) { 460469 cxix = dopoptoloop(cxstack_ix); 460469 if (cxix < 0) 3 DIE(aTHX_ "Can't \"next\" outside a loop block"); } else { 2865 cxix = dopoptolabel(cPVOP->op_pv); 2865 if (cxix < 0) ###### DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); } 463331 if (cxix < cxstack_ix) 130256 dounwind(cxix); /* clear off anything above the scope we're re-entering, but * save the rest until after a possible continue block */ 463331 inner = PL_scopestack_ix; 463331 TOPBLOCK(cx); 463331 if (PL_scopestack_ix < inner) 130256 leave_scope(PL_scopestack[PL_scopestack_ix]); 463331 PL_curcop = cx->blk_oldcop; 463331 return cx->blk_loop.next_op; } PP(pp_redo) 3213 { dVAR; 3213 I32 cxix; 3213 register PERL_CONTEXT *cx; 3213 I32 oldsave; 3213 OP* redo_op; 3213 if (PL_op->op_flags & OPf_SPECIAL) { 3196 cxix = dopoptoloop(cxstack_ix); 3196 if (cxix < 0) ###### DIE(aTHX_ "Can't \"redo\" outside a loop block"); } else { 17 cxix = dopoptolabel(cPVOP->op_pv); 17 if (cxix < 0) ###### DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); } 3213 if (cxix < cxstack_ix) 45 dounwind(cxix); 3213 redo_op = cxstack[cxix].blk_loop.redo_op; 3213 if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ 24 cxstack_ix++; 24 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); 24 redo_op = redo_op->op_next; } 3213 TOPBLOCK(cx); 3213 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 3213 LEAVE_SCOPE(oldsave); 3213 FREETMPS; 3213 PL_curcop = cx->blk_oldcop; 3213 return redo_op; } STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) 47107 { 47107 OP *kid = Nullop; 47107 OP **ops = opstack; 47107 static const char too_deep[] = "Target of goto is too deeply nested"; 47107 if (ops >= oplimit) ###### Perl_croak(aTHX_ too_deep); 47107 if (o->op_type == OP_LEAVE || o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || o->op_type == OP_LEAVESUB || o->op_type == OP_LEAVETRY) { 3589 *ops++ = cUNOPo->op_first; 3589 if (ops >= oplimit) ###### Perl_croak(aTHX_ too_deep); } 47107 *ops = 0; 47107 if (o->op_flags & OPf_KIDS) { /* First try all the kids at this level, since that's likeliest. */ 94262 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 69723 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && kCOP->cop_label && strEQ(kCOP->cop_label, label)) 822 return kid; } 68648 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 45495 if (kid == PL_lastgotoprobe) 115 continue; 45380 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 3350 if (ops == opstack) 256 *ops++ = kid; 3094 else if (ops[-1]->op_type == OP_NEXTSTATE || ops[-1]->op_type == OP_DBSTATE) 1634 ops[-1] = kid; else 1460 *ops++ = kid; } 45380 if ((o = dofindlabel(kid, label, ops, oplimit))) 1386 return o; } } 44899 *ops = 0; 44899 return 0; } PP(pp_dump) ###### { ###### return pp_goto(); /*NOTREACHED*/ } PP(pp_goto) 8782 { 8782 dVAR; dSP; 8782 OP *retop = 0; 8782 I32 ix; 8782 register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 8782 OP *enterops[GOTO_DEPTH]; 8782 const char *label = 0; 8782 const bool do_dump = (PL_op->op_type == OP_DUMP); 8782 static const char must_have_label[] = "goto must have label"; 8782 if (PL_op->op_flags & OPf_STACKED) { 7959 SV * const sv = POPs; /* This egregious kludge implements goto &subroutine */ 7959 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 7956 I32 cxix; 7956 register PERL_CONTEXT *cx; 7956 CV* cv = (CV*)SvRV(sv); 7956 SV** mark; 7956 I32 items = 0; 7956 I32 oldsave; 7956 bool reified = 0; retry: 7957 if (!CvROOT(cv) && !CvXSUB(cv)) { 1 const GV * const gv = CvGV(cv); 1 if (gv) { 1 GV *autogv; 1 SV *tmpstr; /* autoloaded stub? */ 1 if (cv != GvCV(gv) && (cv = GvCV(gv))) ###### goto retry; 1 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE); 1 if (autogv && (cv = GvCV(autogv))) 1 goto retry; ###### tmpstr = sv_newmortal(); ###### gv_efullname3(tmpstr, gv, Nullch); ###### DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); } ###### DIE(aTHX_ "Goto undefined subroutine"); } /* First do some returnish stuff. */ 7956 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ 7956 FREETMPS; 7956 cxix = dopoptosub(cxstack_ix); 7956 if (cxix < 0) ###### DIE(aTHX_ "Can't goto subroutine outside a subroutine"); 7956 if (cxix < cxstack_ix) 65 dounwind(cxix); 7956 TOPBLOCK(cx); 7956 SPAGAIN; /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ 7956 if (CxTYPE(cx) == CXt_EVAL) { 2 if (CxREALEVAL(cx)) 1 DIE(aTHX_ "Can't goto subroutine from an eval-string"); else 1 DIE(aTHX_ "Can't goto subroutine from an eval-block"); } 7954 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { /* put @_ back onto stack */ 7895 AV* av = cx->blk_sub.argarray; 7895 items = AvFILLp(av) + 1; 7895 EXTEND(SP, items+1); /* @_ could have been extended. */ 7895 Copy(AvARRAY(av), SP + 1, items, SV*); 7895 SvREFCNT_dec(GvAV(PL_defgv)); 7895 GvAV(PL_defgv) = cx->blk_sub.savearray; 7895 CLEAR_ARGARRAY(av); /* abandon @_ if it got reified */ 7895 if (AvREAL(av)) { 875 reified = 1; 875 SvREFCNT_dec(av); 875 av = newAV(); 875 av_extend(av, items-1); 875 AvREIFY_only(av); 875 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); } } 59 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ 4 AV* av; 4 av = GvAV(PL_defgv); 4 items = AvFILLp(av) + 1; 4 EXTEND(SP, items+1); /* @_ could have been extended. */ 4 Copy(AvARRAY(av), SP + 1, items, SV*); } 7954 mark = SP; 7954 SP += items; 7954 if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 7953 SvREFCNT_dec(cx->blk_sub.cv); 7954 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 7954 LEAVE_SCOPE(oldsave); /* Now do some callish stuff. */ 7954 SAVETMPS; 7954 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ 7954 if (CvXSUB(cv)) { 184 OP* retop = cx->blk_sub.retop; 184 if (reified) { ###### I32 index; ###### for (index=0; index 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 */ { 184 SV **newsp; 184 I32 gimme; /* XS subs don't have a CxSUB, so pop it */ 184 POPBLOCK(cx, PL_curpm); /* Push a mark for the start of arglist */ 184 PUSHMARK(mark); 184 PUTBACK; 184 (void)(*CvXSUB(cv))(aTHX_ cv); /* Put these at the bottom since the vars are set but not used */ 180 PERL_UNUSED_VAR(newsp); 180 PERL_UNUSED_VAR(gimme); } 180 LEAVE; 180 return retop; } else { 7770 AV* padlist = CvPADLIST(cv); 7770 if (CxTYPE(cx) == CXt_EVAL) { ###### PL_in_eval = cx->blk_eval.old_in_eval; ###### PL_eval_root = cx->blk_eval.old_eval_root; ###### cx->cx_type = CXt_SUB; ###### cx->blk_sub.hasargs = 0; } 7770 cx->blk_sub.cv = cv; 7770 cx->blk_sub.olddepth = (U16)CvDEPTH(cv); 7770 CvDEPTH(cv)++; 7770 if (CvDEPTH(cv) < 2) 7104 (void)SvREFCNT_inc(cv); else { 666 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) ###### sub_crush_depth(cv); 666 pad_push(padlist, CvDEPTH(cv)); } 7770 SAVECOMPPAD(); 7770 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 7770 if (cx->blk_sub.hasargs) { 7715 AV* av = (AV*)PAD_SVl(0); 7715 SV** ary; 7715 cx->blk_sub.savearray = GvAV(PL_defgv); 7715 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 7715 CX_CURPAD_SAVE(cx->blk_sub); 7715 cx->blk_sub.argarray = av; 7715 if (items >= AvMAX(av) + 1) { 575 ary = AvALLOC(av); 575 if (AvARRAY(av) != ary) { ###### AvMAX(av) += AvARRAY(av) - AvALLOC(av); ###### SvPV_set(av, (char*)ary); } 575 if (items >= AvMAX(av) + 1) { 575 AvMAX(av) = items - 1; 575 Renew(ary,items+1,SV*); 575 AvALLOC(av) = ary; 575 SvPV_set(av, (char*)ary); } } 7715 ++mark; 7715 Copy(mark,AvARRAY(av),items,SV*); 7715 AvFILLp(av) = items - 1; 7715 assert(!AvREAL(av)); 7715 if (reified) { /* transfer 'ownership' of refcnts to new @_ */ 875 AvREAL_on(av); 875 AvREIFY_off(av); } 19753 while (items--) { 12038 if (*mark) 12038 SvTEMP_off(*mark); 12038 mark++; } } 7770 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ /* * We do not care about using sv to call CV; * it's for informational purposes only. */ ###### SV *sv = GvSV(PL_DBsub); ###### CV *gotocv; ###### save_item(sv); ###### if (PERLDB_SUB_NN) { ###### int type = SvTYPE(sv); ###### if (type < SVt_PVIV && type != SVt_IV) ###### sv_upgrade(sv, SVt_PVIV); ###### (void)SvIOK_on(sv); ###### SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */ } else { ###### gv_efullname3(sv, CvGV(cv), Nullch); } ###### if ( PERLDB_GOTO && (gotocv = get_cv("DB::goto", FALSE)) ) { ###### PUSHMARK( PL_stack_sp ); ###### call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); ###### PL_stack_sp--; } } 7770 RETURNOP(CvSTART(cv)); } } else { 3 label = SvPV_nolen_const(sv); 3 if (!(do_dump || *label)) ###### DIE(aTHX_ must_have_label); } } 823 else if (PL_op->op_flags & OPf_SPECIAL) { ###### if (! do_dump) ###### DIE(aTHX_ must_have_label); } else 823 label = cPVOP->op_pv; 826 if (label && *label) { 826 OP *gotoprobe = 0; 826 bool leaving_eval = FALSE; 826 bool in_block = FALSE; 826 PERL_CONTEXT *last_eval_cx = 0; /* find label */ 826 PL_lastgotoprobe = 0; 826 *enterops = 0; 1731 for (ix = cxstack_ix; ix >= 0; ix--) { 1728 cx = &cxstack[ix]; 1728 switch (CxTYPE(cx)) { case CXt_EVAL: 11 leaving_eval = TRUE; 11 if (!CxTRYBLOCK(cx)) { 5 gotoprobe = (last_eval_cx ? last_eval_cx->blk_eval.old_eval_root : PL_eval_root); 5 last_eval_cx = cx; 5 break; } /* else fall through */ case CXt_LOOP: 551 gotoprobe = cx->blk_oldcop->op_sibling; 551 break; case CXt_SUBST: 732 continue; case CXt_BLOCK: 732 if (ix) { 719 gotoprobe = cx->blk_oldcop->op_sibling; 719 in_block = TRUE; } else 13 gotoprobe = PL_main_root; 13 break; case CXt_SUB: 440 if (CvDEPTH(cx->blk_sub.cv)) { 439 gotoprobe = CvROOT(cx->blk_sub.cv); 439 break; } /* FALL THROUGH */ case CXt_FORMAT: case CXt_NULL: 1 DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); default: ###### if (ix) ###### DIE(aTHX_ "panic: goto"); ###### gotoprobe = PL_main_root; 1727 break; } 1727 if (gotoprobe) { 1727 retop = dofindlabel(gotoprobe, label, enterops, enterops + GOTO_DEPTH); 1727 if (retop) 822 break; } 905 PL_lastgotoprobe = gotoprobe; } 825 if (!retop) 3 DIE(aTHX_ "Can't find label %s", label); /* if we're leaving an eval, check before we pop any frames that we're not going to punt, otherwise the error won't be caught */ 822 if (leaving_eval && *enterops && enterops[1]) { 2 I32 i; 4 for (i = 1; enterops[i]; i++) 4 if (enterops[i]->op_type == OP_ENTERITER) 2 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); } /* pop unwanted frames */ 820 if (ix < cxstack_ix) { 600 I32 oldsave; 600 if (ix < 0) ###### ix = 0; 600 dounwind(ix); 600 TOPBLOCK(cx); 600 oldsave = PL_scopestack[PL_scopestack_ix]; 600 LEAVE_SCOPE(oldsave); } /* push wanted frames */ 820 if (*enterops && enterops[1]) { 11 OP *oldop = PL_op; 11 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 33 for (; enterops[ix]; ix++) { 11 PL_op = enterops[ix]; /* Eventually we may want to stack the needed arguments * for each op. For now, we punt on the hard ones. */ 11 if (PL_op->op_type == OP_ENTERITER) ###### DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 11 CALL_FPTR(PL_op->op_ppaddr)(aTHX); } 11 PL_op = oldop; } } 820 if (do_dump) { #ifdef VMS if (!retop) retop = PL_main_start; #endif ###### PL_restartop = retop; ###### PL_do_undump = TRUE; ###### my_unexec(); ###### PL_restartop = 0; /* hmm, must be GNU unexec().. */ ###### PL_do_undump = FALSE; } 820 RETURNOP(retop); } PP(pp_exit) 344 { 344 dSP; 344 I32 anum; 344 if (MAXARG < 1) 47 anum = 0; else { 297 anum = SvIVx(POPs); #ifdef VMS if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); #endif } 344 PL_exit_flags |= PERL_EXIT_EXPECTED; 344 my_exit(anum); PUSHs(&PL_sv_undef); RETURN; } #ifdef NOTYET PP(pp_nswitch) { dSP; const NV value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); if (value < 0.0) { if (((NV)match) > value) --match; /* was fractional--truncate other way */ } match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; else if (match > cCOP->uop.scop.scop_max) match = cCOP->uop.scop.scop_max; PL_op = cCOP->uop.scop.scop_next[match]; RETURNOP(PL_op); } PP(pp_cswitch) { dSP; register I32 match; if (PL_multiline) PL_op = PL_op->op_next; /* can't assume anything */ else { match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255; match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; else if (match > cCOP->uop.scop.scop_max) match = cCOP->uop.scop.scop_max; PL_op = cCOP->uop.scop.scop_next[match]; } RETURNOP(PL_op); } #endif /* Eval. */ STATIC void S_save_lines(pTHX_ AV *array, SV *sv) ###### { ###### const char *s = SvPVX_const(sv); ###### const char *send = SvPVX_const(sv) + SvCUR(sv); ###### I32 line = 1; ###### while (s && s < send) { ###### const char *t; ###### SV *tmpstr = NEWSV(85,0); ###### sv_upgrade(tmpstr, SVt_PVMG); ###### t = strchr(s, '\n'); ###### if (t) ###### t++; else ###### t = send; ###### sv_setpvn(tmpstr, s, t - s); ###### av_store(array, line++, tmpstr); ###### s = t; } } STATIC void S_docatch_body(pTHX) 8091 { 8091 CALLRUNOPS(aTHX); return; } STATIC OP * S_docatch(pTHX_ OP *o) 8035 { 8035 int ret; 8035 OP * const oldop = PL_op; 8035 dJMPENV; #ifdef DEBUGGING 8035 assert(CATCH_GET == TRUE); #endif 8035 PL_op = o; 8035 JMPENV_PUSH(ret); 8107 switch (ret) { case 0: 8035 assert(cxstack_ix >= 0); 8035 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 8035 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; redo_body: 8091 docatch_body(); 8019 break; case 3: /* die caught by an inner eval - continue inner loop */ /* 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. */ 70 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL); 70 if (PL_restartop && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env) { 56 PL_op = PL_restartop; 56 PL_restartop = 0; 56 goto redo_body; } /* FALL THROUGH */ default: 16 JMPENV_POP; 16 PL_op = oldop; 16 JMPENV_JUMP(ret); /* NOTREACHED */ } 8019 JMPENV_POP; 8019 PL_op = oldop; 8019 return Nullop; } OP * Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* sv Text to convert to OP tree. */ /* startop op_free() this to undo. */ /* code Short string id of the caller. */ 1077 { 1077 dVAR; dSP; /* Make POPBLOCK work. */ 1077 PERL_CONTEXT *cx; 1077 SV **newsp; 1077 I32 gimme = G_VOID; 1077 I32 optype; 1077 OP dummy; 1077 OP *rop; 1077 char tbuf[TYPE_DIGITS(long) + 12 + 10]; 1077 char *tmpbuf = tbuf; 1077 char *safestr; 1077 int runtime; 1077 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ 1077 ENTER; 1077 lex_start(sv); 1077 SAVETMPS; /* switch to eval mode */ 1077 if (IN_PERL_COMPILETIME) { 736 SAVECOPSTASH_FREE(&PL_compiling); 736 CopSTASH_set(&PL_compiling, PL_curstash); } 1077 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { ###### SV * const sv = sv_newmortal(); ###### Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", code, (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); ###### tmpbuf = SvPVX(sv); } else 1077 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); 1077 SAVECOPFILE_FREE(&PL_compiling); 1077 CopFILE_set(&PL_compiling, tmpbuf+2); 1077 SAVECOPLINE(&PL_compiling); 1077 CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ 1077 safestr = savepv(tmpbuf); 1077 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 1077 SAVEHINTS(); #ifdef OP_IN_REGISTER PL_opsave = op; #else 1077 SAVEVPTR(PL_op); #endif /* we get here either during compilation, or via pp_regcomp at runtime */ 1077 runtime = IN_PERL_RUNTIME; 1077 if (runtime) 341 runcv = find_runcv(NULL); 1077 PL_op = &dummy; 1077 PL_op->op_type = OP_ENTEREVAL; 1077 PL_op->op_flags = 0; /* Avoid uninit warning. */ 1077 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); 1077 PUSHEVAL(cx, 0, Nullgv); 1077 if (runtime) 341 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); else 736 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); 1069 POPBLOCK(cx,PL_curpm); 1069 POPEVAL(cx); 1069 (*startop)->op_type = OP_NULL; 1069 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; 1069 lex_end(); /* XXX DAPM do this properly one year */ 1069 *padp = (AV*)SvREFCNT_inc(PL_comppad); 1069 LEAVE; 1069 if (IN_PERL_COMPILETIME) 728 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef OP_IN_REGISTER op = PL_opsave; #endif 1069 PERL_UNUSED_VAR(newsp); 1069 PERL_UNUSED_VAR(optype); 1069 return rop; } /* =for apidoc find_runcv Locate the CV corresponding to the currently executing sub or eval. If db_seqp is non_null, skip CVs that are in the DB package and populate *db_seqp with the cop sequence number at the point that the DB:: code was entered. (allows debuggers to eval in the scope of the breakpoint rather than in in the scope of the debugger itself). =cut */ CV* Perl_find_runcv(pTHX_ U32 *db_seqp) 68194 { 68194 PERL_SI *si; 68194 if (db_seqp) 67801 *db_seqp = PL_curcop->cop_seq; 93206 for (si = PL_curstackinfo; si; si = si->si_prev) { 68197 I32 ix; 252677 for (ix = si->si_cxix; ix >= 0; ix--) { 227665 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); 227665 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 19894 CV * const cv = cx->blk_sub.cv; /* skip DB:: code */ 19894 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { 3 *db_seqp = cx->blk_oldcop->cop_seq; 3 continue; } 19891 return cv; } 207771 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 23294 return PL_compcv; } } 25009 return PL_main_cv; } /* Compile a require/do, an eval '', or a /(?{...})/. * In the last case, startop is non-null, and contains the address of * a pointer that should be set to the just-compiled code. * outside is the lexically enclosing CV (if any) that invoked us. */ /* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 101767 { 101767 dVAR; dSP; 101767 OP *saveop = PL_op; 101767 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) : EVAL_INEVAL); 101767 PUSHMARK(SP); 101767 SAVESPTR(PL_compcv); 101767 PL_compcv = (CV*)NEWSV(1104,0); 101767 sv_upgrade((SV *)PL_compcv, SVt_PVCV); 101767 CvEVAL_on(PL_compcv); 101767 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 101767 cxstack[cxstack_ix].blk_eval.cv = PL_compcv; 101767 CvOUTSIDE_SEQ(PL_compcv) = seq; 101767 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); /* set up a scratch pad */ 101767 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); 101767 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ 101767 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 30144 SAVESPTR(PL_curstash); 30144 PL_curstash = CopSTASH(PL_curcop); } 101767 SAVESPTR(PL_beginav); 101767 PL_beginav = newAV(); 101767 SAVEFREESV(PL_beginav); 101767 SAVEI32(PL_error_count); /* try to compile it */ 101767 PL_eval_root = Nullop; 101767 PL_error_count = 0; 101767 PL_curcop = &PL_compiling; 101767 PL_curcop->cop_arybase = 0; 101767 if (saveop && saveop->op_flags & OPf_SPECIAL) 8 PL_in_eval |= EVAL_KEEPERR; else 101759 sv_setpvn(ERRSV,"",0); 101767 if (yyparse() || PL_error_count || !PL_eval_root) { 194 SV **newsp; /* Used by POPBLOCK. */ 194 PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 194 I32 optype = 0; /* Might be reset by POPEVAL. */ 194 const char *msg; 194 PL_op = saveop; 194 if (PL_eval_root) { 186 op_free(PL_eval_root); 186 PL_eval_root = Nullop; } 194 SP = PL_stack_base + POPMARK; /* pop original mark */ 194 if (!startop) { 186 POPBLOCK(cx,PL_curpm); 186 POPEVAL(cx); } 194 lex_end(); 194 LEAVE; 194 msg = SvPVx_nolen_const(ERRSV); 194 if (optype == OP_REQUIRE) { 7 const SV * const nsv = cx->blk_eval.old_namesv; 7 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); 7 DIE(aTHX_ "%sCompilation failed in require", *msg ? msg : "Unknown error\n"); } 187 else if (startop) { 8 POPBLOCK(cx,PL_curpm); 8 POPEVAL(cx); 8 Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } else { 179 if (!*msg) { ###### sv_setpv(ERRSV, "Compilation error"); } } 179 PERL_UNUSED_VAR(newsp); 179 RETPUSHUNDEF; } 100861 CopLINE_set(&PL_compiling, 0); 100861 if (startop) { 1069 *startop = PL_eval_root; } else 99792 SAVEFREEOP(PL_eval_root); /* Set the context for this new optree. * If the last op is an OP_REQUIRE, force scalar context. * Otherwise, propagate the context from the eval(). */ 100861 if (PL_eval_root->op_type == OP_LEAVEEVAL && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type == OP_REQUIRE) 361 scalar(PL_eval_root); 100500 else if (gimme & G_VOID) 13514 scalarvoid(PL_eval_root); 86986 else if (gimme & G_ARRAY) 576 list(PL_eval_root); else 86410 scalar(PL_eval_root); 100861 DEBUG_x(dump_eval()); /* Register with debugger: */ 100861 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { 18 CV *cv = get_cv("DB::postponed", FALSE); 18 if (cv) { ###### dSP; ###### PUSHMARK(SP); ###### XPUSHs((SV*)CopFILEGV(&PL_compiling)); ###### PUTBACK; ###### call_sv((SV*)cv, G_DISCARD); } } /* compiled okay, so do it */ 100861 CvDEPTH(PL_compcv) = 1; 100861 SP = PL_stack_base + POPMARK; /* pop original mark */ 100861 PL_op = saveop; /* The caller may need it. */ 100861 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ 100861 RETURNOP(PL_eval_start); } STATIC PerlIO * S_doopen_pm(pTHX_ const char *name, const char *mode) 41605 { #ifndef PERL_DISABLE_PMC 41605 const STRLEN namelen = strlen(name); 41605 PerlIO *fp; 41605 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { 34911 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); 34911 const char * const pmc = SvPV_nolen_const(pmcsv); 34911 Stat_t pmcstat; 34911 if (PerlLIO_stat(pmc, &pmcstat) < 0) { 34911 fp = PerlIO_open(name, mode); } else { ###### Stat_t pmstat; ###### if (PerlLIO_stat(name, &pmstat) < 0 || pmstat.st_mtime < pmcstat.st_mtime) { ###### fp = PerlIO_open(pmc, mode); } else { ###### fp = PerlIO_open(name, mode); } } 34911 SvREFCNT_dec(pmcsv); } else { 6694 fp = PerlIO_open(name, mode); } 41605 return fp; #else return PerlIO_open(name, mode); #endif /* !PERL_DISABLE_PMC */ } PP(pp_require) 146496 { 146496 dVAR; dSP; 146496 register PERL_CONTEXT *cx; 146496 SV *sv; 146496 const char *name; 146496 STRLEN len; 146496 const char *tryname = Nullch; 146496 SV *namesv = Nullsv; 146496 SV** svp; 146496 const I32 gimme = GIMME_V; 146496 PerlIO *tryrsfp = 0; 146496 int filter_has_file = 0; 146496 GV *filter_child_proc = 0; 146496 SV *filter_state = 0; 146496 SV *filter_sub = 0; 146496 SV *hook_sv = 0; 146496 SV *encoding; 146496 OP *op; 146496 sv = POPs; 146496 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { 10640 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */ 2 Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "v-string in use/require non-portable"); 10640 sv = new_version(sv); 10640 if (!sv_derived_from(PL_patchlevel, "version")) 1515 (void *)upg_version(PL_patchlevel); 10640 if ( vcmp(sv,PL_patchlevel) > 0 ) 6 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", vnormal(sv), vnormal(PL_patchlevel)); 10634 RETPUSHYES; } 135856 name = SvPV_const(sv, len); 135856 if (!(name && len > 0 && *name)) ###### DIE(aTHX_ "Null filename used"); 135856 TAINT_PROPER("require"); 135855 if (PL_op->op_type == OP_REQUIRE && (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { 100205 if (*svp != &PL_sv_undef) 100202 RETPUSHYES; else 3 DIE(aTHX_ "Compilation failed in require"); } /* prepare to compile file */ 35650 if (path_is_absolute(name)) { 1032 tryname = name; 1032 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); } #ifdef MACOS_TRADITIONAL if (!tryrsfp) { char newname[256]; MacPerl_CanonDir(name, newname, 1); if (path_is_absolute(newname)) { tryname = newname; tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); } } #endif 35650 if (!tryrsfp) { 34620 AV *ar = GvAVn(PL_incgv); 34620 I32 i; #ifdef VMS char *unixname; if ((unixname = tounixspec(name, Nullch)) != Nullch) #endif { 34620 namesv = NEWSV(806, 0); 40863 for (i = 0; i <= AvFILL(ar); i++) { 40588 SV *dirsv = *av_fetch(ar, i, TRUE); 40588 if (SvROK(dirsv)) { 14 int count; 14 SV *loader = dirsv; 14 if (SvTYPE(SvRV(loader)) == SVt_PVAV && !sv_isobject(loader)) { 4 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); } 14 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", PTR2UV(SvRV(dirsv)), name); 14 tryname = SvPVX_const(namesv); 14 tryrsfp = 0; 14 ENTER; 14 SAVETMPS; 14 EXTEND(SP, 2); 14 PUSHMARK(SP); 14 PUSHs(dirsv); 14 PUSHs(sv); 14 PUTBACK; 14 if (sv_isobject(loader)) 3 count = call_method("INC", G_ARRAY); else 11 count = call_sv(loader, G_ARRAY); 14 SPAGAIN; 14 if (count > 0) { 14 int i = 0; 14 SV *arg; 14 SP -= count - 1; 14 arg = SP[i++]; 14 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { 11 arg = SvRV(arg); } 14 if (SvTYPE(arg) == SVt_PVGV) { 11 IO *io = GvIO((GV *)arg); 11 ++filter_has_file; 11 if (io) { 11 tryrsfp = IoIFP(io); 11 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 { 11 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { ###### PerlIO_close(IoOFP(io)); } 11 IoIFP(io) = Nullfp; 11 IoOFP(io) = Nullfp; } } 11 if (i < count) { ###### arg = SP[i++]; } } 14 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { ###### filter_sub = arg; ###### (void)SvREFCNT_inc(filter_sub); ###### if (i < count) { ###### filter_state = SP[i]; ###### (void)SvREFCNT_inc(filter_state); } ###### if (tryrsfp == 0) { ###### tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE); } } 14 SP--; } 14 PUTBACK; 14 FREETMPS; 14 LEAVE; 14 if (tryrsfp) { 11 hook_sv = dirsv; 11 break; } 3 filter_has_file = 0; 3 if (filter_child_proc) { ###### SvREFCNT_dec(filter_child_proc); ###### filter_child_proc = 0; } 3 if (filter_state) { ###### SvREFCNT_dec(filter_state); ###### filter_state = 0; } 3 if (filter_sub) { ###### SvREFCNT_dec(filter_sub); ###### filter_sub = 0; } } else { 40574 if (!path_is_absolute(name) #ifdef MACOS_TRADITIONAL /* We consider paths of the form :a:b ambiguous and interpret them first as global then as local */ || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) #endif ) { 40573 const char *dir = SvPVx_nolen_const(dirsv); #ifdef MACOS_TRADITIONAL char buf1[256]; char buf2[256]; MacPerl_CanonDir(name, buf2, 1); Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); #else # ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); # else # ifdef SYMBIAN 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 40573 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); # endif # endif #endif 40573 TAINT_PROPER("require"); 40573 tryname = SvPVX_const(namesv); 40573 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); 40573 if (tryrsfp) { 34334 if (tryname[0] == '.' && tryname[1] == '/') 212 tryname += 2; 212 break; } } } } } } 35650 SAVECOPFILE_FREE(&PL_compiling); 35650 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); 35650 SvREFCNT_dec(namesv); 35650 if (!tryrsfp) { 275 if (PL_op->op_type == OP_REQUIRE) { 266 const char *msgstr = name; 266 if (namesv) { /* did we lookup @INC? */ 266 SV *msg = sv_2mortal(newSVpv(msgstr,0)); 266 SV *dirmsgsv = NEWSV(0, 0); 266 AV *ar = GvAVn(PL_incgv); 266 I32 i; 266 sv_catpvn(msg, " in @INC", 8); 266 if (instr(SvPVX_const(msg), ".h ")) ###### sv_catpv(msg, " (change .h to .ph maybe?)"); 266 if (instr(SvPVX_const(msg), ".ph ")) 3 sv_catpv(msg, " (did you run h2ph?)"); 266 sv_catpv(msg, " (@INC contains:"); 1699 for (i = 0; i <= AvFILL(ar); i++) { 1433 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE)); 1433 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); 1433 sv_catsv(msg, dirmsgsv); } 266 sv_catpvn(msg, ")", 1); 266 SvREFCNT_dec(dirmsgsv); 266 msgstr = SvPV_nolen_const(msg); } 266 DIE(aTHX_ "Can't locate %s", msgstr); } 9 RETPUSHUNDEF; } else 35375 SETERRNO(0, SS_NORMAL); /* Assume success here to prevent recursive requirement. */ 35375 len = strlen(name); /* Check whether a hook in @INC has already filled %INC */ 35375 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { 35374 (void)hv_store(GvHVn(PL_incgv), name, len, 10 (hook_sv ? SvREFCNT_inc(hook_sv) : newSVpv(CopFILE(&PL_compiling), 0)), 0 ); } 35375 ENTER; 35375 SAVETMPS; 35375 lex_start(sv_2mortal(newSVpvn("",0))); 35375 SAVEGENERICSV(PL_rsfp_filters); 35375 PL_rsfp_filters = Nullav; 35375 PL_rsfp = tryrsfp; 35375 SAVEHINTS(); 35375 PL_hints = 0; 35375 SAVESPTR(PL_compiling.cop_warnings); 35375 if (PL_dowarn & G_WARN_ALL_ON) 36 PL_compiling.cop_warnings = pWARN_ALL ; 35339 else if (PL_dowarn & G_WARN_ALL_OFF) 30 PL_compiling.cop_warnings = pWARN_NONE ; 35309 else if (PL_taint_warn) 16 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); else 35293 PL_compiling.cop_warnings = pWARN_STD ; 35375 SAVESPTR(PL_compiling.cop_io); 35375 PL_compiling.cop_io = Nullsv; 35375 if (filter_sub || filter_child_proc) { ###### SV *datasv = filter_add(run_user_filter, Nullsv); ###### IoLINES(datasv) = filter_has_file; ###### IoFMT_GV(datasv) = (GV *)filter_child_proc; ###### IoTOP_GV(datasv) = (GV *)filter_state; ###### IoBOTTOM_GV(datasv) = (GV *)filter_sub; } /* switch to eval mode */ 35375 PUSHBLOCK(cx, CXt_EVAL, SP); 35375 PUSHEVAL(cx, name, Nullgv); 35375 cx->blk_eval.retop = PL_op->op_next; 35375 SAVECOPLINE(&PL_compiling); 35375 CopLINE_set(&PL_compiling, 0); 35375 PUTBACK; /* Store and reset encoding. */ 35375 encoding = PL_encoding; 35375 PL_encoding = Nullsv; 35375 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); /* Restore encoding. */ 35357 PL_encoding = encoding; 35357 return op; } PP(pp_dofile) 4969 { 4969 return pp_require(); } PP(pp_entereval) 65319 { 65319 dVAR; dSP; 65319 register PERL_CONTEXT *cx; 65319 dPOPss; 65319 const I32 gimme = GIMME_V, was = PL_sub_generation; 65319 char tbuf[TYPE_DIGITS(long) + 12]; 65319 char *tmpbuf = tbuf; 65319 char *safestr; 65319 STRLEN len; 65319 OP *ret; 65319 CV* runcv; 65319 U32 seq; 65319 if (!SvPV_const(sv,len)) ###### RETPUSHUNDEF; 65319 TAINT_PROPER("eval"); 65315 ENTER; 65315 lex_start(sv); 65315 SAVETMPS; /* switch to eval mode */ 65315 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { ###### SV *sv = sv_newmortal(); ###### Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); ###### tmpbuf = SvPVX(sv); } else 65315 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); 65315 SAVECOPFILE_FREE(&PL_compiling); 65315 CopFILE_set(&PL_compiling, tmpbuf+2); 65315 SAVECOPLINE(&PL_compiling); 65315 CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ 65315 safestr = savepv(tmpbuf); 65315 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 65315 SAVEHINTS(); 65315 PL_hints = PL_op->op_targ; 65315 SAVESPTR(PL_compiling.cop_warnings); 65315 if (specialWARN(PL_curcop->cop_warnings)) 65205 PL_compiling.cop_warnings = PL_curcop->cop_warnings; else { 110 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); 110 SAVEFREESV(PL_compiling.cop_warnings); } 65315 SAVESPTR(PL_compiling.cop_io); 65315 if (specialCopIO(PL_curcop->cop_io)) 65315 PL_compiling.cop_io = PL_curcop->cop_io; else { ###### PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); ###### SAVEFREESV(PL_compiling.cop_io); } /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the * scope of the code being debugged. Passing &seq gets find_runcv * to do the dirty work for us */ 65315 runcv = find_runcv(&seq); 65315 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); 65315 PUSHEVAL(cx, 0, Nullgv); 65315 cx->blk_eval.retop = PL_op->op_next; /* prepare to compile string */ 65315 if (PERLDB_LINE && PL_curstash != PL_debstash) ###### save_lines(CopFILEAV(&PL_compiling), PL_linestr); 65315 PUTBACK; 65315 ret = doeval(gimme, NULL, runcv, seq); 64608 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. */ } 64608 return DOCATCH(ret); } PP(pp_leaveeval) 94520 { 94520 dVAR; dSP; 94520 register SV **mark; 94520 SV **newsp; 94520 PMOP *newpm; 94520 I32 gimme; 94520 register PERL_CONTEXT *cx; 94520 OP *retop; 94520 const U8 save_flags = PL_op -> op_flags; 94520 I32 optype; 94520 POPBLOCK(cx,newpm); 94520 POPEVAL(cx); 94520 retop = cx->blk_eval.retop; 94520 TAINT_NOT; 94520 if (gimme == G_VOID) 13588 MARK = newsp; 80932 else if (gimme == G_SCALAR) { 80433 MARK = newsp + 1; 80433 if (MARK <= SP) { 80433 if (SvFLAGS(TOPs) & SVs_TEMP) 13880 *MARK = TOPs; else 66553 *MARK = sv_mortalcopy(TOPs); } else { ###### MEXTEND(mark,0); ###### *MARK = &PL_sv_undef; } 80433 SP = MARK; } else { /* in case LEAVE wipes old return values */ 16272 for (mark = newsp + 1; mark <= SP; mark++) { 15773 if (!(SvFLAGS(*mark) & SVs_TEMP)) { 7605 *mark = sv_mortalcopy(*mark); 7605 TAINT_NOT; /* Each item is independent */ } } } 94520 PL_curpm = newpm; /* Don't pop $1 et al till now */ #ifdef DEBUGGING 94520 assert(CvDEPTH(PL_compcv) == 1); #endif 94520 CvDEPTH(PL_compcv) = 0; 94520 lex_end(); 94520 if (optype == OP_REQUIRE && 464 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ 1 SV * const nsv = cx->blk_eval.old_namesv; 1 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); 1 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); /* die_where() did LEAVE, or we won't be here */ } else { 94519 LEAVE; 94519 if (!(save_flags & OPf_SPECIAL)) 94519 sv_setpvn(ERRSV,"",0); } 94519 RETURNOP(retop); } PP(pp_entertry) 96786 { 96786 dVAR; dSP; 96786 register PERL_CONTEXT *cx; 96786 const I32 gimme = GIMME_V; 96786 ENTER; 96786 SAVETMPS; 96786 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); 96786 PUSHEVAL(cx, 0, 0); 96786 cx->blk_eval.retop = cLOGOP->op_other->op_next; 96786 PL_in_eval = EVAL_INEVAL; 96786 sv_setpvn(ERRSV,"",0); 96786 PUTBACK; 96786 return DOCATCH(PL_op->op_next); } PP(pp_leavetry) 93770 { 93770 dVAR; dSP; 93770 register SV **mark; 93770 SV **newsp; 93770 PMOP *newpm; 93770 I32 gimme; 93770 register PERL_CONTEXT *cx; 93770 I32 optype; 93770 POPBLOCK(cx,newpm); 93770 POPEVAL(cx); 93770 PERL_UNUSED_VAR(optype); 93770 TAINT_NOT; 93770 if (gimme == G_VOID) 37787 SP = newsp; 55983 else if (gimme == G_SCALAR) { 55639 MARK = newsp + 1; 55639 if (MARK <= SP) { 55639 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 7416 *MARK = TOPs; else 48223 *MARK = sv_mortalcopy(TOPs); } else { ###### MEXTEND(mark,0); ###### *MARK = &PL_sv_undef; } 55639 SP = MARK; } else { /* in case LEAVE wipes old return values */ 1521 for (mark = newsp + 1; mark <= SP; mark++) { 1177 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { 17 *mark = sv_mortalcopy(*mark); 17 TAINT_NOT; /* Each item is independent */ } } } 93770 PL_curpm = newpm; /* Don't pop $1 et al till now */ 93770 LEAVE; 93770 sv_setpvn(ERRSV,"",0); 93770 RETURN; } STATIC OP * S_doparseform(pTHX_ SV *sv) 121 { 121 STRLEN len; 121 register char *s = SvPV_force(sv, len); 121 register char *send = s + len; 121 register char *base = Nullch; 121 register I32 skipspaces = 0; 121 bool noblank = FALSE; 121 bool repeat = FALSE; 121 bool postspace = FALSE; 121 U32 *fops; 121 register U32 *fpc; 121 U32 *linepc = 0; 121 register I32 arg; 121 bool ischop; 121 bool unchopnum = FALSE; 121 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ 121 if (len == 0) 1 Perl_croak(aTHX_ "Null picture in formline"); /* estimate the buffer size needed */ 1819 for (base = s; s <= send; s++) { 1699 if (*s == '\n' || *s == '@' || *s == '^') 212 maxops += 10; } 120 s = base; 120 base = Nullch; 120 New(804, fops, maxops, U32); 120 fpc = fops; 120 if (s < send) { 120 linepc = fpc; 120 *fpc++ = FF_LINEMARK; 120 noblank = repeat = FALSE; 120 base = s; } 918 while (s <= send) { 798 switch (*s++) { default: 341 skipspaces = 0; 341 continue; case '~': 12 if (*s == '~') { 10 repeat = TRUE; 10 *s = ' '; } 12 noblank = TRUE; 12 s[-1] = ' '; /* FALL THROUGH */ case ' ': case '\t': 190 skipspaces++; 190 continue; case 0: 55 if (s < send) { 2 skipspaces = 0; 2 continue; } /* else FALL THROUGH */ case '\n': 128 arg = s - base; 128 skipspaces++; 128 arg -= skipspaces; 128 if (arg) { 24 if (postspace) 5 *fpc++ = FF_SPACE; 24 *fpc++ = FF_LITERAL; 24 *fpc++ = (U16)arg; } 128 postspace = FALSE; 128 if (s <= send) 75 skipspaces--; 128 if (skipspaces) { 63 *fpc++ = FF_SKIP; 63 *fpc++ = (U16)skipspaces; } 128 skipspaces = 0; 128 if (s <= send) 75 *fpc++ = FF_NEWLINE; 128 if (noblank) { 12 *fpc++ = FF_BLANK; 12 if (repeat) 10 arg = fpc - linepc + 1; else 2 arg = 0; 12 *fpc++ = (U16)arg; } 128 if (s < send) { 8 linepc = fpc; 8 *fpc++ = FF_LINEMARK; 8 noblank = repeat = FALSE; 8 base = s; } else 120 s++; 120 continue; case '@': case '^': 137 ischop = s[-1] == '^'; 137 if (postspace) { 16 *fpc++ = FF_SPACE; 16 postspace = FALSE; } 137 arg = (s - base) - 1; 137 if (arg) { 45 *fpc++ = FF_LITERAL; 45 *fpc++ = (U16)arg; } 137 base = s - 1; 137 *fpc++ = FF_FETCH; 137 if (*s == '*') { 8 s++; 8 *fpc++ = 2; /* skip the @* or ^* */ 8 if (ischop) { ###### *fpc++ = FF_LINESNGL; ###### *fpc++ = FF_CHOP; } else 8 *fpc++ = FF_LINEGLOB; } 129 else if (*s == '#' || (*s == '.' && s[1] == '#')) { 21 arg = ischop ? 512 : 0; 21 base = s - 1; 84 while (*s == '#') 63 s++; 21 if (*s == '.') { 12 const char * const f = ++s; 26 while (*s == '#') 14 s++; 12 arg |= 256 + (s - f); } 21 *fpc++ = s - base; /* fieldsize for FETCH */ 21 *fpc++ = FF_DECIMAL; 21 *fpc++ = (U16)arg; 21 unchopnum |= ! ischop; } 108 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ 14 arg = ischop ? 512 : 0; 14 base = s - 1; 14 s++; /* skip the '0' first */ 40 while (*s == '#') 26 s++; 14 if (*s == '.') { 6 const char * const f = ++s; 18 while (*s == '#') 12 s++; 6 arg |= 256 + (s - f); } 14 *fpc++ = s - base; /* fieldsize for FETCH */ 14 *fpc++ = FF_0DECIMAL; 14 *fpc++ = (U16)arg; 14 unchopnum |= ! ischop; } else { 94 I32 prespace = 0; 94 bool ismore = FALSE; 94 if (*s == '>') { 147 while (*++s == '>') ; 30 prespace = FF_SPACE; } 64 else if (*s == '|') { 16 while (*++s == '|') ; 4 prespace = FF_HALFSPACE; 4 postspace = TRUE; } else { 60 if (*s == '<') 510 while (*++s == '<') ; 60 postspace = TRUE; } 94 if (*s == '.' && s[1] == '.' && s[2] == '.') { 2 s += 3; 2 ismore = TRUE; } 94 *fpc++ = s - base; /* fieldsize for FETCH */ 94 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 94 if (prespace) 34 *fpc++ = (U16)prespace; 94 *fpc++ = FF_ITEM; 94 if (ismore) 2 *fpc++ = FF_MORE; 94 if (ischop) 19 *fpc++ = FF_CHOP; } 137 base = s; 137 skipspaces = 0; 137 continue; } } 120 *fpc++ = FF_END; 120 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ 120 arg = fpc - fops; { /* need to jump to the next word */ 120 int z; 120 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; 120 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); 120 s = SvPVX(sv) + SvCUR(sv) + z; } 120 Copy(fops, s, arg, U32); 120 Safefree(fops); 120 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); 120 SvCOMPILED_on(sv); 120 if (unchopnum && repeat) 1 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); 119 return 0; } STATIC bool S_num_overflow(NV value, I32 fldsize, I32 frcsize) 32 { /* Can value be printed in fldsize chars, using %*.*f ? */ 32 NV pwr = 1; 32 NV eps = 0.5; 32 bool res = FALSE; 32 int intsize = fldsize - (value < 0 ? 1 : 0); 32 if (frcsize & 256) 18 intsize--; 32 frcsize &= 255; 32 intsize -= frcsize; 147 while (intsize--) pwr *= 10.0; 58 while (frcsize--) eps /= 10.0; 32 if( value >= 0 ){ 26 if (value + eps >= pwr) 6 res = TRUE; } else { 6