X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=bdacfce91744fac874c6e2d6d5895d7c0f576fa5;hb=ae706db49f17350f7e2ed5eccdc792223f4ea020;hp=401f60f3802aa51b3a83fc769f1be9ea16712817;hpb=8ff629d935fd2dba7977969e7922b9cd55cc75d2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 401f60f..bdacfce 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. @@ -40,6 +40,7 @@ PP(pp_wantarray) { + dVAR; dSP; I32 cxix; EXTEND(SP, 1); @@ -60,6 +61,7 @@ PP(pp_wantarray) 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; @@ -69,6 +71,7 @@ PP(pp_regcreset) PP(pp_regcomp) { + dVAR; dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; @@ -180,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; @@ -188,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) @@ -240,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,7 +284,7 @@ PP(pp_substcont) 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,12 +318,12 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *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; @@ -385,20 +389,20 @@ Perl_rxres_free(pTHX_ void **rsp) PP(pp_formline) { - dSP; dMARK; dORIGMARK; + 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; @@ -406,8 +410,8 @@ PP(pp_formline) ? (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; @@ -1047,6 +1051,7 @@ PP(pp_mapwhile) PP(pp_range) { + dVAR; if (GIMME == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) @@ -1057,6 +1062,7 @@ PP(pp_range) PP(pp_flip) { + dVAR; dSP; if (GIMME == G_ARRAY) { @@ -1111,7 +1117,7 @@ PP(pp_flip) PP(pp_flop) { - dSP; + dVAR; dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; @@ -1176,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); } @@ -1193,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--) { @@ -1209,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)); @@ -1228,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; } @@ -1238,6 +1252,7 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { + dVAR; const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; @@ -1259,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 */ @@ -1271,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]; @@ -1296,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]; @@ -1313,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]; @@ -1336,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) { @@ -1375,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) @@ -1397,7 +1460,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) if (PL_in_eval & EVAL_KEEPERR) { static const char prefix[] = "\t(in cleanup) "; SV * const err = ERRSV; - const char *e = Nullch; + const char *e = NULL; if (!SvPOK(err)) sv_setpvn(err,"",0); else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { @@ -1405,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); @@ -1482,7 +1545,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) PP(pp_xor) { - dSP; dPOPTOPssrl; + dVAR; dSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1491,6 +1554,7 @@ PP(pp_xor) PP(pp_caller) { + dVAR; dSP; register I32 cxix = dopoptosub(cxstack_ix); register const PERL_CONTEXT *cx; @@ -1564,17 +1628,17 @@ PP(pp_caller) /* 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; @@ -1639,7 +1703,7 @@ PP(pp_caller) * it could have been extended by warnings::register */ SV **bits_all; HV * const bits = get_hv("warnings::Bits", FALSE); - if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { + if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { mask = newSVsv(*bits_all); } else { @@ -1655,6 +1719,7 @@ PP(pp_caller) PP(pp_reset) { + dVAR; dSP; const char * const tmps = (MAXARG < 1) ? "" : POPpconstx; sv_reset(tmps, CopSTASH(PL_curcop)); @@ -1727,7 +1792,7 @@ PP(pp_enteriter) 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 @@ -1760,6 +1825,9 @@ PP(pp_enteriter) #endif } + if (PL_op->op_private & OPpITER_DEF) + cxtype |= CXp_FOR_DEF; + ENTER; PUSHBLOCK(cx, cxtype, SP); @@ -1985,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); @@ -2006,7 +2074,7 @@ PP(pp_last) SV **newsp; PMOP *newpm; SV **mark; - SV *sv = Nullsv; + SV *sv = NULL; if (PL_op->op_flags & OPf_SPECIAL) { @@ -2155,6 +2223,7 @@ PP(pp_redo) STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) { + dVAR; OP **ops = opstack; static const char too_deep[] = "Target of goto is too deeply nested"; @@ -2202,12 +2271,12 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) 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"; @@ -2238,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"); @@ -2414,7 +2483,7 @@ PP(pp_goto) (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)) ) { @@ -2440,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 */ @@ -2559,6 +2628,7 @@ PP(pp_goto) PP(pp_exit) { + dVAR; dSP; I32 anum; @@ -2578,46 +2648,6 @@ 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 @@ -2647,6 +2677,7 @@ S_save_lines(pTHX_ AV *array, SV *sv) STATIC void S_docatch_body(pTHX) { + dVAR; CALLRUNOPS(aTHX); return; } @@ -2654,6 +2685,7 @@ S_docatch_body(pTHX) STATIC OP * S_docatch(pTHX_ OP *o) { + dVAR; int ret; OP * const oldop = PL_op; dJMPENV; @@ -2811,6 +2843,7 @@ than in the scope of the debugger itself). CV* Perl_find_runcv(pTHX_ U32 *db_seqp) { + dVAR; PERL_SI *si; if (db_seqp) @@ -2889,7 +2922,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_error_count = 0; PL_curcop = &PL_compiling; PL_curcop->cop_arybase = 0; - if (saveop && saveop->op_flags & OPf_SPECIAL) + if (saveop && saveop->op_type != OP_REQUIRE && saveop->op_flags & OPf_SPECIAL) PL_in_eval |= EVAL_KEEPERR; else sv_setpvn(ERRSV,"",0); @@ -2980,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 @@ -2991,27 +3040,27 @@ S_doopen_pm(pTHX_ const char *name, const char *mode) const char * const pmc = SvPV_nolen_const(pmcsv); Stat_t pmcstat; if (PerlLIO_stat(pmc, &pmcstat) < 0) { - fp = PerlIO_open(name, mode); + fp = check_type_and_open(name, mode); } else { 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 */ } @@ -3022,15 +3071,15 @@ PP(pp_require) SV *sv; const char *name; STRLEN len; - const char *tryname = Nullch; - SV *namesv = Nullsv; + 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; @@ -3092,7 +3141,7 @@ PP(pp_require) I32 i; #ifdef VMS char *unixname; - if ((unixname = tounixspec(name, Nullch)) != Nullch) + if ((unixname = tounixspec(name, NULL)) != NULL) #endif { namesv = NEWSV(806, 0); @@ -3112,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; @@ -3179,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--; @@ -3199,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 { @@ -3229,7 +3277,7 @@ 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); @@ -3271,29 +3319,28 @@ PP(pp_require) if (PL_op->op_type == OP_REQUIRE) { const char *msgstr = name; if(errno == EMFILE) { - SV * const msg = sv_2mortal(newSVpv(msgstr,0)); - sv_catpv(msg, ": "); - sv_catpv(msg, Strerror(errno)); + 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? */ - SV * const msg = sv_2mortal(newSVpv(msgstr,0)); - SV * const dirmsgsv = NEWSV(0, 0); AV * const 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:"); + 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++) { - const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE)); - Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); - sv_catsv(msg, dirmsgsv); + sv_catpvs(msg, " "); + sv_catsv(msg, *av_fetch(ar, i, TRUE)); } - sv_catpvn(msg, ")", 1); - SvREFCNT_dec(dirmsgsv); + sv_catpvs(msg, ")"); msgstr = SvPV_nolen_const(msg); } } @@ -3318,9 +3365,9 @@ PP(pp_require) 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(); @@ -3335,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 * const datasv = filter_add(S_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; @@ -3357,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)); @@ -3371,7 +3418,7 @@ PP(pp_entereval) { dVAR; dSP; register PERL_CONTEXT *cx; - dPOPss; + SV *sv; const I32 gimme = GIMME_V; const I32 was = PL_sub_generation; char tbuf[TYPE_DIGITS(long) + 12]; @@ -3381,6 +3428,12 @@ 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_nolen_const(sv)) RETPUSHUNDEF; @@ -3415,6 +3468,8 @@ PP(pp_entereval) 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; @@ -3543,7 +3598,6 @@ PP(pp_entertry) PP(pp_leavetry) { dVAR; dSP; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -3558,6 +3612,7 @@ PP(pp_leavetry) 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)) @@ -3573,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); @@ -3587,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; @@ -3615,7 +4279,7 @@ S_doparseform(pTHX_ SV *sv) maxops += 10; } s = base; - base = Nullch; + base = NULL; Newx(fops, maxops, U32); fpc = fops; @@ -3796,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)