X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=867556184f896864350a9e85b973eefc4518bd4a;hb=a11019f8bfc1b4438fdb32560361d443c701e293;hp=b6c72e84cd4ca491c53da775641899c1ec6116b4;hpb=6300418df733fa6a39202abfea4908f73899f1ad;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index b6c72e8..8675561 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, 2005, 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. @@ -38,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); @@ -60,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; @@ -76,6 +71,7 @@ PP(pp_regcreset) PP(pp_regcomp) { + dVAR; dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; @@ -122,7 +118,7 @@ PP(pp_regcomp) 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)); } @@ -187,6 +183,7 @@ PP(pp_regcomp) PP(pp_substcont) { + dVAR; dSP; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register PMOP * const pm = (PMOP*) cLOGOP->op_other; @@ -195,7 +192,7 @@ PP(pp_substcont) register char *m = cx->sb_m; char *orig = cx->sb_orig; register REGEXP * const rx = cx->sb_rx; - SV *nsv = Nullsv; + SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); if(old != rx) { if(old) @@ -204,7 +201,7 @@ PP(pp_substcont) } 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++) { const I32 saviters = cx->sb_iters; @@ -214,6 +211,7 @@ PP(pp_substcont) 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, @@ -222,7 +220,7 @@ PP(pp_substcont) ? (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) { @@ -246,7 +244,7 @@ PP(pp_substcont) SvLEN_set(targ, SvLEN(dstr)); if (DO_UTF8(dstr)) SvUTF8_on(targ); - SvPV_set(dstr, (char*)0); + SvPV_set(dstr, NULL); sv_free(dstr); TAINT_IF(cx->sb_rxtainted & 1); @@ -280,13 +278,13 @@ PP(pp_substcont) } 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) SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { - sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); + sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0); mg = mg_find(sv, PERL_MAGIC_regex_global); } i = m - orig; @@ -314,18 +312,18 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 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_OLD_COPY_ON_WRITE *p++ = PTR2UV(rx->saved_copy); - rx->saved_copy = Nullsv; + rx->saved_copy = NULL; #endif *p++ = rx->nparens; @@ -368,10 +366,17 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) void Perl_rxres_free(pTHX_ void **rsp) { - UV *p = (UV*)*rsp; + UV * const p = (UV*)*rsp; if (p) { +#ifdef PERL_POISON + void *tmp = INT2PTR(char*,*p); + Safefree(tmp); + if (*p) + Poison(*p, 1, sizeof(*p)); +#else Safefree(INT2PTR(char*,*p)); +#endif #ifdef PERL_OLD_COPY_ON_WRITE if (p[1]) { SvREFCNT_dec (INT2PTR(SV*,p[1])); @@ -384,29 +389,29 @@ Perl_rxres_free(pTHX_ void **rsp) 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; const char *f; register I32 arg; - register SV *sv = Nullsv; - const 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); - const 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 = SvPOK(tmpForm) + 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; + SV * nsv = NULL; + OP * parseres = NULL; const char *fmt; bool oneline; @@ -724,7 +729,7 @@ PP(pp_formline) { const char *s = chophere; if (chopspace) { - while (*s && isSPACE(*s)) + while (isSPACE(*s)) s++; } sv_chop(sv,s); @@ -862,7 +867,7 @@ PP(pp_formline) const char *s = chophere; const char *send = item + len; if (chopspace) { - while (*s && isSPACE(*s) && s < send) + while (isSPACE(*s) && (s < send)) s++; } if (s < send) { @@ -933,11 +938,6 @@ PP(pp_grepstart) return ((LOGOP*)PL_op->op_next)->op_other; } -PP(pp_mapstart) -{ - DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ -} - PP(pp_mapwhile) { dVAR; dSP; @@ -1051,6 +1051,7 @@ PP(pp_mapwhile) PP(pp_range) { + dVAR; if (GIMME == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) @@ -1061,6 +1062,7 @@ PP(pp_range) PP(pp_flip) { + dVAR; dSP; if (GIMME == G_ARRAY) { @@ -1068,7 +1070,7 @@ PP(pp_flip) } else { dTOPss; - SV *targ = PAD_SV(PL_op->op_targ); + SV * const targ = PAD_SV(PL_op->op_targ); int flip = 0; if (PL_op->op_private & OPpFLIP_LINENUM) { @@ -1076,8 +1078,9 @@ PP(pp_flip) 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_fetchpv(".", TRUE, SVt_PV); + if (gv && GvSV(gv)) + flip = SvIV(sv) == SvIV(GvSV(gv)); } } else { flip = SvTRUE(sv); @@ -1114,15 +1117,13 @@ PP(pp_flip) PP(pp_flop) { - dSP; + dVAR; dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; - 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; @@ -1145,9 +1146,9 @@ PP(pp_flop) } } else { - SV *final = sv_mortalcopy(right); + SV * const final = sv_mortalcopy(right); STRLEN len; - const char *tmps = SvPV_const(final, len); + const char * const tmps = SvPV_const(final, len); SV *sv = sv_mortalcopy(left); SvPV_force_nolen(sv); @@ -1181,7 +1182,7 @@ PP(pp_flop) if (flop) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); - sv_catpvn(targ, "E0", 2); + sv_catpvs(targ, "E0"); } SETs(targ); } @@ -1198,12 +1199,15 @@ static const char * const context_name[] = { "loop", "substitution", "block", - "format" + "format", + "given", + "when" }; STATIC I32 S_dopoptolabel(pTHX_ const char *label) { + dVAR; register I32 i; for (i = cxstack_ix; i >= 0; i--) { @@ -1214,6 +1218,8 @@ S_dopoptolabel(pTHX_ const char *label) 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)); @@ -1233,9 +1239,12 @@ S_dopoptolabel(pTHX_ const char *label) return i; } + + I32 Perl_dowantarray(pTHX) { + dVAR; const I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } @@ -1243,6 +1252,7 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { + dVAR; const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; @@ -1264,6 +1274,7 @@ Perl_block_gimme(pTHX) I32 Perl_is_lvalue_sub(pTHX) { + dVAR; const I32 cxix = dopoptosub(cxstack_ix); assert(cxix >= 0); /* We should only be called from inside subs */ @@ -1276,12 +1287,14 @@ Perl_is_lvalue_sub(pTHX) STATIC I32 S_dopoptosub(pTHX_ I32 startingblock) { + dVAR; return dopoptosub_at(cxstack, startingblock); } STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { + dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; @@ -1301,6 +1314,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) { + dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT *cx = &cxstack[i]; @@ -1318,6 +1332,7 @@ S_dopoptoeval(pTHX_ I32 startingblock) STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) { + dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstack[i]; @@ -1341,9 +1356,51 @@ 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) { + dVAR; I32 optype; while (cxstack_ix > cxix) { @@ -1380,6 +1437,7 @@ Perl_dounwind(pTHX_ I32 cxix) void Perl_qerror(pTHX_ SV *err) { + dVAR; if (PL_in_eval) sv_catsv(ERRSV, err); else if (PL_errors) @@ -1401,8 +1459,8 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) if (message) { if (PL_in_eval & EVAL_KEEPERR) { static const char prefix[] = "\t(in cleanup) "; - SV *err = ERRSV; - const char *e = Nullch; + SV * const err = ERRSV; + const char *e = NULL; if (!SvPOK(err)) sv_setpvn(err,"",0); else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { @@ -1410,7 +1468,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) 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); @@ -1465,7 +1523,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { - const char* msg = SvPVx_nolen_const(ERRSV); + 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); @@ -1487,66 +1545,16 @@ Perl_die_where(pTHX_ const 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 const PERL_CONTEXT *cx; @@ -1616,21 +1624,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 * const sv = NEWSV(49, 0); - gv_efullname3(sv, cvgv, Nullch); + 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; @@ -1666,9 +1674,8 @@ PP(pp_caller) 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_fetchpv("DB::args", TRUE, SVt_PVAV); + PL_dbargs = GvAV(gv_AVadd(tmpgv)); GvMULTI_on(tmpgv); AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } @@ -1685,7 +1692,7 @@ PP(pp_caller) HINT_PRIVATE_MASK))); { SV * mask ; - SV * old_warnings = cx->blk_oldcop->cop_warnings ; + SV * const old_warnings = cx->blk_oldcop->cop_warnings ; if (old_warnings == pWARN_NONE || (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) @@ -1695,8 +1702,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 { @@ -1712,23 +1719,14 @@ PP(pp_caller) PP(pp_reset) { + dVAR; dSP; - const char *tmps; - - if (MAXARG < 1) - tmps = ""; - else - tmps = POPpconstx; + const char * const tmps = (MAXARG < 1) ? "" : 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) @@ -1743,14 +1741,12 @@ PP(pp_dbstate) || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; - register CV *cv; register PERL_CONTEXT *cx; 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"); @@ -1767,29 +1763,36 @@ PP(pp_dbstate) hasargs = 0; SPAGAIN; - PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB_DB(cx); - cx->blk_sub.retop = PL_op->op_next; - CvDEPTH(cv)++; - PAD_SET_CUR(CvPADLIST(cv),1); - RETURNOP(CvSTART(cv)); + if (CvXSUB(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) { dVAR; dSP; dMARK; register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; - U32 cxtype = CXt_LOOP; + U32 cxtype = CXt_LOOP | CXp_FOREACH; #ifdef USE_ITHREADS void *iterdata; #endif @@ -1813,7 +1816,7 @@ 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); @@ -1822,6 +1825,9 @@ PP(pp_enteriter) #endif } + if (PL_op->op_private & OPpITER_DEF) + cxtype |= CXp_FOR_DEF; + ENTER; PUSHBLOCK(cx, cxtype, SP); @@ -1834,13 +1840,19 @@ 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 { cx->blk_loop.iterlval = newSVsv(sv); @@ -1849,8 +1861,8 @@ PP(pp_enteriter) } } 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; } } @@ -1858,8 +1870,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; @@ -1929,7 +1941,6 @@ PP(pp_leaveloop) PP(pp_return) { dVAR; dSP; dMARK; - I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; @@ -1940,24 +1951,34 @@ PP(pp_return) 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: @@ -2032,7 +2053,7 @@ PP(pp_return) POPSUB(cx,sv); /* release CV and @_ ... */ } else - sv = Nullsv; + sv = NULL; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); @@ -2048,12 +2069,13 @@ PP(pp_last) register PERL_CONTEXT *cx; I32 pop2 = 0; I32 gimme; - I32 optype = 0; + I32 optype; OP *nextop; SV **newsp; PMOP *newpm; SV **mark; - SV *sv = Nullsv; + SV *sv = NULL; + if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -2069,7 +2091,6 @@ PP(pp_last) dounwind(cxix); POPBLOCK(cx,newpm); - PERL_UNUSED_VAR(optype); cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { @@ -2127,6 +2148,8 @@ PP(pp_last) PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); + PERL_UNUSED_VAR(optype); + PERL_UNUSED_VAR(gimme); return nextop; } @@ -2200,7 +2223,7 @@ PP(pp_redo) STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) { - OP *kid = Nullop; + dVAR; OP **ops = opstack; static const char too_deep[] = "Target of goto is too deeply nested"; @@ -2218,6 +2241,7 @@ S_dofindlabel(pTHX_ OP *o, const 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) && @@ -2244,26 +2268,20 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) return 0; } -PP(pp_dump) -{ - return pp_goto(); - /*NOTREACHED*/ -} - PP(pp_goto) { dVAR; dSP; - OP *retop = 0; + OP *retop = NULL; I32 ix; register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; - const char *label = 0; + const char *label = NULL; const bool do_dump = (PL_op->op_type == OP_DUMP); static const char must_have_label[] = "goto must have label"; if (PL_op->op_flags & OPf_STACKED) { - SV *sv = POPs; + SV * const sv = POPs; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { @@ -2289,7 +2307,7 @@ PP(pp_goto) if (autogv && (cv = GvCV(autogv))) goto retry; tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, Nullch); + gv_efullname3(tmpstr, gv, NULL); DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); } DIE(aTHX_ "Goto undefined subroutine"); @@ -2312,6 +2330,8 @@ PP(pp_goto) 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; @@ -2333,8 +2353,7 @@ PP(pp_goto) } } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ - AV* av; - av = GvAV(PL_defgv); + AV* const av = GvAV(PL_defgv); items = AvFILLp(av) + 1; EXTEND(SP, items+1); /* @_ could have been extended. */ Copy(AvARRAY(av), SP + 1, items, SV*); @@ -2408,7 +2427,8 @@ PP(pp_goto) sub_crush_depth(cv); 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); @@ -2452,18 +2472,18 @@ PP(pp_goto) * We do not care about using sv to call CV; * it's for informational purposes only. */ - SV *sv = GvSV(PL_DBsub); + SV * const sv = GvSV(PL_DBsub); CV *gotocv; save_item(sv); if (PERLDB_SUB_NN) { - int type = SvTYPE(sv); + const 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); + gv_efullname3(sv, CvGV(cv), NULL); } if ( PERLDB_GOTO && (gotocv = get_cv("DB::goto", FALSE)) ) { @@ -2489,10 +2509,10 @@ 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 */ @@ -2524,7 +2544,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; } @@ -2576,7 +2596,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]; @@ -2608,6 +2628,7 @@ PP(pp_goto) PP(pp_exit) { + dVAR; dSP; I32 anum; @@ -2627,58 +2648,18 @@ PP(pp_exit) 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); + const char * const send = SvPVX_const(sv) + SvCUR(sv); I32 line = 1; while (s && s < send) { const char *t; - SV *tmpstr = NEWSV(85,0); + SV * const tmpstr = NEWSV(85,0); sv_upgrade(tmpstr, SVt_PVMG); t = strchr(s, '\n'); @@ -2696,6 +2677,7 @@ S_save_lines(pTHX_ AV *array, SV *sv) STATIC void S_docatch_body(pTHX) { + dVAR; CALLRUNOPS(aTHX); return; } @@ -2703,6 +2685,7 @@ S_docatch_body(pTHX) STATIC OP * S_docatch(pTHX_ OP *o) { + dVAR; int ret; OP * const oldop = PL_op; dJMPENV; @@ -2756,10 +2739,11 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { + /* 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; @@ -2768,6 +2752,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) char *safestr; int runtime; CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ + STRLEN len; ENTER; lex_start(sv); @@ -2779,14 +2764,16 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const 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_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, + (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -2796,8 +2783,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const 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; @@ -2834,6 +2821,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) #ifdef OP_IN_REGISTER op = PL_opsave; #endif + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(optype); + return rop; } @@ -2845,7 +2835,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 */ @@ -2853,6 +2843,7 @@ than in in the scope of the debugger itself). CV* Perl_find_runcv(pTHX_ U32 *db_seqp) { + dVAR; PERL_SI *si; if (db_seqp) @@ -2889,7 +2880,7 @@ STATIC OP * S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; - OP *saveop = PL_op; + OP * const saveop = PL_op; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -2937,8 +2928,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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. */ + const char *msg; PL_op = saveop; if (PL_eval_root) { @@ -2952,8 +2944,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } lex_end(); LEAVE; + + msg = SvPVx_nolen_const(ERRSV); if (optype == OP_REQUIRE) { - const char* const msg = SvPVx_nolen_const(ERRSV); const SV * const nsv = cx->blk_eval.old_namesv; (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); @@ -2961,19 +2954,17 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) *msg ? msg : "Unknown error\n"); } else if (startop) { - const char* msg = SvPVx_nolen_const(ERRSV); - POPBLOCK(cx,PL_curpm); POPEVAL(cx); Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } else { - const char* msg = SvPVx_nolen_const(ERRSV); if (!*msg) { sv_setpv(ERRSV, "Compilation error"); } } + PERL_UNUSED_VAR(newsp); RETPUSHUNDEF; } CopLINE_set(&PL_compiling, 0); @@ -3001,7 +2992,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* Register with debugger: */ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { - CV *cv = get_cv("DB::postponed", FALSE); + CV * const cv = get_cv("DB::postponed", FALSE); if (cv) { dSP; PUSHMARK(SP); @@ -3022,6 +3013,22 @@ 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) { + return Nullfp; + } + + if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { + Perl_die(aTHX_ "%s %s not allowed in require", + S_ISDIR(st.st_mode) ? "Directory" : "Block device", name); + } + return PerlIO_open(name, mode); +} + +STATIC PerlIO * S_doopen_pm(pTHX_ const char *name, const char *mode) { #ifndef PERL_DISABLE_PMC @@ -3029,31 +3036,31 @@ S_doopen_pm(pTHX_ const char *name, const char *mode) PerlIO *fp; if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { - SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); + SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); const char * const pmc = SvPV_nolen_const(pmcsv); - Stat_t pmstat; Stat_t pmcstat; if (PerlLIO_stat(pmc, &pmcstat) < 0) { - fp = PerlIO_open(name, mode); + fp = check_type_and_open(name, mode); } else { + Stat_t pmstat; if (PerlLIO_stat(name, &pmstat) < 0 || pmstat.st_mtime < pmcstat.st_mtime) { - fp = PerlIO_open(pmc, mode); + fp = check_type_and_open(pmc, mode); } else { - fp = PerlIO_open(name, mode); + fp = check_type_and_open(name, 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 */ } @@ -3064,16 +3071,15 @@ PP(pp_require) SV *sv; const char *name; STRLEN len; - const char *tryname = Nullch; - SV *namesv = Nullsv; - SV** svp; + const char *tryname = NULL; + SV *namesv = NULL; const I32 gimme = GIMME_V; - PerlIO *tryrsfp = 0; 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; + GV *filter_child_proc = NULL; + SV *filter_state = NULL; + SV *filter_sub = NULL; + SV *hook_sv = NULL; SV *encoding; OP *op; @@ -3086,9 +3092,16 @@ PP(pp_require) sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) (void *)upg_version(PL_patchlevel); - if ( vcmp(sv,PL_patchlevel) > 0 ) - DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - vnormal(sv), vnormal(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", + vnormal(sv), vnormal(PL_patchlevel)); + } + else { + if ( vcmp(sv,PL_patchlevel) > 0 ) + DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", + vnormal(sv), vnormal(PL_patchlevel)); + } RETPUSHYES; } @@ -3096,12 +3109,14 @@ PP(pp_require) 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 */ @@ -3122,11 +3137,11 @@ 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); @@ -3146,7 +3161,7 @@ PP(pp_require) Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", PTR2UV(SvRV(dirsv)), name); tryname = SvPVX_const(namesv); - tryrsfp = 0; + tryrsfp = NULL; ENTER; SAVETMPS; @@ -3213,9 +3228,8 @@ PP(pp_require) (void)SvREFCNT_inc(filter_state); } - if (tryrsfp == 0) { - tryrsfp = PerlIO_open("/dev/null", - PERL_SCRIPT_MODE); + if (!tryrsfp) { + tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE); } } SP--; @@ -3233,15 +3247,15 @@ PP(pp_require) filter_has_file = 0; if (filter_child_proc) { SvREFCNT_dec(filter_child_proc); - filter_child_proc = 0; + filter_child_proc = 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 { @@ -3263,12 +3277,12 @@ PP(pp_require) #else # 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 -# ifdef SYMBIAN +# ifdef __SYMBIAN32__ if (PL_origfilename[0] && PL_origfilename[1] == ':' && !(dir[0] && dir[1] == ':')) @@ -3304,25 +3318,31 @@ PP(pp_require) if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { const 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_const(msg), ".h ")) - sv_catpv(msg, " (change .h to .ph maybe?)"); - if (instr(SvPVX_const(msg), ".ph ")) - sv_catpv(msg, " (did you run h2ph?)"); - sv_catpv(msg, " (@INC contains:"); - for (i = 0; i <= AvFILL(ar); i++) { - const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE)); - Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); - sv_catsv(msg, dirmsgsv); - } - sv_catpvn(msg, ")", 1); - SvREFCNT_dec(dirmsgsv); + 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); } @@ -3333,20 +3353,21 @@ 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(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(); @@ -3361,10 +3382,10 @@ PP(pp_require) else PL_compiling.cop_warnings = pWARN_STD ; SAVESPTR(PL_compiling.cop_io); - PL_compiling.cop_io = Nullsv; + PL_compiling.cop_io = NULL; if (filter_sub || filter_child_proc) { - SV *datasv = filter_add(run_user_filter, Nullsv); + 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; @@ -3383,7 +3404,7 @@ PP(pp_require) /* Store and reset encoding. */ encoding = PL_encoding; - PL_encoding = Nullsv; + PL_encoding = NULL; op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); @@ -3393,17 +3414,13 @@ PP(pp_require) return op; } -PP(pp_dofile) -{ - return pp_require(); -} - PP(pp_entereval) { dVAR; dSP; register PERL_CONTEXT *cx; - dPOPss; - const 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; @@ -3411,8 +3428,14 @@ PP(pp_entereval) OP *ret; CV* runcv; U32 seq; + HV *saved_hh = NULL; + + if (PL_op->op_private & OPpEVAL_HAS_HH) { + saved_hh = (HV*) SvREFCNT_inc(POPs); + } + sv = POPs; - if (!SvPV_const(sv,len)) + if (!SvPV_nolen_const(sv)) RETPUSHUNDEF; TAINT_PROPER("eval"); @@ -3423,14 +3446,15 @@ PP(pp_entereval) /* switch to eval mode */ if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { - SV *sv = sv_newmortal(); + SV * const 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); + len = SvCUR(sv); } else - sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -3440,10 +3464,12 @@ 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; + if (saved_hh) + GvHV(PL_hintgv) = saved_hh; SAVESPTR(PL_compiling.cop_warnings); if (specialWARN(PL_curcop->cop_warnings)) PL_compiling.cop_warnings = PL_curcop->cop_warnings; @@ -3572,7 +3598,6 @@ PP(pp_entertry) PP(pp_leavetry) { dVAR; dSP; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -3581,11 +3606,13 @@ PP(pp_leavetry) POPBLOCK(cx,newpm); POPEVAL(cx); + 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)) @@ -3601,6 +3628,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); @@ -3615,20 +3643,628 @@ PP(pp_leavetry) 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; + SV **mark; + + POPBLOCK(cx,newpm); + assert(CxTYPE(cx) == CXt_GIVEN); + mark = newsp; + + 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(Nullhv, Nullhv); +} + +/* This version of do_smartmatch() implements the following + table of smart matches: + + $a $b Type of Match Implied Matching Code + ====== ===== ===================== ============= + (overloading trumps everything) + + Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b) + Any Code[+] scalar sub truth match if $b->($a) + + Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b)) + Hash Array hash value slice truth match if $a->{any(@$b)} + Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/ + Hash Any hash entry existence match if exists $a->{$b} + + Array Array arrays are identical[*] match if $a È~~Ç $b + Array Regex array grep match if any(@$a) =~ /$b/ + Array Num array contains number match if any($a) == $b + Array Any array contains string match if any($a) eq $b + + Any undef undefined match if !defined $a + Any Regex pattern match match if $a =~ /$b/ + Code() Code() results are equal match if $a->() eq $b->() + Any Code() simple closure truth match if $b->() (ignoring $a) + Num numish[!] numeric equality match if $a == $b + Any Str string equality match if $a eq $b + Any Num numeric equality match if $a == $b + + Any Any string equality match if $a eq $b + + + + - this must be a code reference whose prototype (if present) is not "" + (subs with a "" prototype are dealt with by the 'Code()' entry lower down) + * - if a circular reference is found, we fall back to referential equality + ! - either a real number, or a string that looks_like_number() + + */ +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; + 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(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 (Nullhv == seen_this) { + seen_this = newHV(); + (void) sv_2mortal((SV *) seen_this); + } + if (Nullhv == 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 ((PL_curcop->op_private & HINT_INTEGER) == 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(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(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 ((PL_curcop->op_private & HINT_INTEGER) == 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->blk_loop.next_op; + else + return cx->blk_givwhen.leave_op; +} + STATIC OP * 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; @@ -3643,9 +4279,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) { @@ -3824,7 +4460,7 @@ 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) @@ -3861,14 +4497,14 @@ 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) { dVAR; - SV *datasv = FILTER_DATA(idx); + SV * const datasv = FILTER_DATA(idx); const 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); + GV * const filter_child_proc = (GV *)IoFMT_GV(datasv); + SV * const filter_state = (SV *)IoTOP_GV(datasv); + SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv); int len = 0; /* I was having segfault trouble under Linux 2.2.5 after a @@ -3925,7 +4561,7 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SvREFCNT_dec(filter_sub); IoBOTTOM_GV(datasv) = Nullgv; } - filter_del(run_user_filter); + filter_del(S_run_user_filter); } return len; @@ -3938,11 +4574,12 @@ S_path_is_absolute(pTHX_ 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; }