X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=1e669c805833185e6571cda02e046927c9e97218;hb=34445a8a84bb43293be0a94405ecd2a0e3baceac;hp=81a4f5699f7790250146b1498a5194c4c7611a29;hpb=51371543ca1a75ed152020ad0846b5b8cf11c32f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 81a4f56..1e669c8 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -29,7 +29,6 @@ #include #endif -#define HOP(pos,off) (IN_UTF8 ? utf8_hop(pos, off) : (pos + off)) /* Hot code. */ @@ -40,7 +39,7 @@ static void unset_cvowner(pTHXo_ void *cvarg); PP(pp_const) { djSP; - XPUSHs(cSVOP->op_sv); + XPUSHs(cSVOP_sv); RETURN; } @@ -58,9 +57,9 @@ PP(pp_gvsv) djSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) - PUSHs(save_scalar(cGVOP->op_gv)); + PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSV(cGVOP->op_gv)); + PUSHs(GvSV(cGVOP_gv)); RETURN; } @@ -69,6 +68,12 @@ PP(pp_null) return NORMAL; } +PP(pp_setstate) +{ + PL_curcop = (COP*)PL_op; + return NORMAL; +} + PP(pp_pushmark) { PUSHMARK(PL_stack_sp); @@ -89,7 +94,7 @@ PP(pp_stringify) PP(pp_gv) { djSP; - XPUSHs((SV*)cGVOP->op_gv); + XPUSHs((SV*)cGVOP_gv); RETURN; } @@ -147,8 +152,14 @@ PP(pp_concat) dPOPTOPssrl; STRLEN len; char *s; + if (TARG != left) { s = SvPV(left,len); + if (TARG == right) { + sv_insert(TARG, 0, 0, s, len); + SETs(TARG); + RETURN; + } sv_setpvn(TARG,s,len); } else if (SvGMAGICAL(TARG)) @@ -158,8 +169,21 @@ PP(pp_concat) s = SvPV_force(TARG, len); } s = SvPV(right,len); - if (SvOK(TARG)) + if (SvOK(TARG)) { +#if defined(PERL_Y2KWARN) + if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_MISC)) { + STRLEN n; + char *s = SvPV(TARG,n); + if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' + && (n == 2 || !isDIGIT(s[n-3]))) + { + Perl_warner(aTHX_ WARN_MISC, "Possible Y2K bug: %s", + "about to append an integer to '19'"); + } + } +#endif sv_catpvn(TARG,s,len); + } else sv_setpvn(TARG,s,len); /* suppress warning */ SETTARG; @@ -215,7 +239,7 @@ PP(pp_preinc) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { @@ -252,7 +276,7 @@ PP(pp_add) PP(pp_aelemfast) { djSP; - AV *av = GvAV((GV*)cSVOP->op_sv); + AV *av = GvAV(cGVOP_gv); U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); @@ -349,7 +373,7 @@ PP(pp_print) SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) Perl_warner(aTHX_ WARN_CLOSED, - "print on closed filehandle %s", SvPV(sv,n_a)); + "print() on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -440,7 +464,7 @@ PP(pp_rv2av) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "an ARRAY"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (GIMME == G_ARRAY) { (void)POPs; RETURN; @@ -540,7 +564,7 @@ PP(pp_rv2hv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a HASH"); if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (GIMME == G_ARRAY) { SP--; RETURN; @@ -583,8 +607,8 @@ PP(pp_rv2hv) if (SvTYPE(hv) == SVt_PVAV) hv = avhv_keys((AV*)hv); if (HvFILL(hv)) - Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld", - (long)HvFILL(hv), (long)HvMAX(hv) + 1); + Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf, + (IV)HvFILL(hv), (IV)HvMAX(hv) + 1); else sv_setiv(TARG, 0); @@ -755,8 +779,8 @@ PP(pp_aassign) } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ - PL_uid = (int)PerlProc_getuid(); - PL_euid = (int)PerlProc_geteuid(); + PL_uid = PerlProc_getuid(); + PL_euid = PerlProc_geteuid(); } if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID @@ -784,8 +808,8 @@ PP(pp_aassign) } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ - PL_gid = (int)PerlProc_getgid(); - PL_egid = (int)PerlProc_getegid(); + PL_gid = PerlProc_getgid(); + PL_egid = PerlProc_getegid(); } PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } @@ -1066,9 +1090,9 @@ Perl_do_readline(pTHX) if (!fp) { if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { - IoFLAGS(io) &= ~IOf_START; IoLINES(io) = 0; if (av_len(GvAVn(PL_last_in_gv)) < 0) { + IoFLAGS(io) &= ~IOf_START; do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); sv_setpvn(GvSV(PL_last_in_gv), "-", 1); SvSETMAGIC(GvSV(PL_last_in_gv)); @@ -1079,7 +1103,6 @@ Perl_do_readline(pTHX) fp = nextargv(PL_last_in_gv); if (!fp) { /* Note: fp != IoIFP(io) */ (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ - IoFLAGS(io) |= IOf_START; } } else if (type == OP_GLOB) { @@ -1171,6 +1194,11 @@ Perl_do_readline(pTHX) } } #else /* !VMS */ +#ifdef MACOS_TRADITIONAL + sv_setpv(tmpcmd, "glob "); + sv_catsv(tmpcmd, tmpglob); + sv_catpv(tmpcmd, " |"); +#else #ifdef DOSISH #ifdef OS2 sv_setpv(tmpcmd, "for a in "); @@ -1202,6 +1230,7 @@ Perl_do_readline(pTHX) #endif #endif /* !CSH */ #endif /* !DOSISH */ +#endif /* MACOS_TRADITIONAL */ (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), FALSE, O_RDONLY, 0, Nullfp); fp = IoIFP(io); @@ -1231,7 +1260,7 @@ Perl_do_readline(pTHX) SV* sv = sv_newmortal(); gv_efullname3(sv, PL_last_in_gv, Nullch); Perl_warner(aTHX_ WARN_CLOSED, - "Read on closed filehandle %s", + "readline() on closed filehandle %s", SvPV_nolen(sv)); } } @@ -1260,12 +1289,11 @@ Perl_do_readline(pTHX) offset = 0; } -/* flip-flop EOF state for a snarfed empty file */ +/* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ - ((gimme != G_SCALAR || SvCUR(sv) \ - || (IoFLAGS(io) & IOf_NOLINE) || IoLINES(io) || !RsSNARF(rs)) \ - ? ((IoFLAGS(io) &= ~IOf_NOLINE), TRUE) \ - : ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + (gimme != G_SCALAR || SvCUR(sv) \ + || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \ + || ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) for (;;) { if (!sv_gets(sv, fp, offset) @@ -1277,7 +1305,6 @@ Perl_do_readline(pTHX) if (fp) continue; (void)do_close(PL_last_in_gv, FALSE); - IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { @@ -1486,12 +1513,14 @@ PP(pp_iter) register PERL_CONTEXT *cx; SV* sv; AV* av; + SV **itersvp; EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; if (CxTYPE(cx) != CXt_LOOP) DIE(aTHX_ "panic: pp_iter"); + itersvp = CxITERVAR(cx); av = cx->blk_loop.iterary; if (SvTYPE(av) != SVt_PVAV) { /* iterate ($min .. $max) */ @@ -1502,11 +1531,9 @@ PP(pp_iter) char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1 - && !SvMAGICAL(*cx->blk_loop.itervar)) - { + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setsv(*cx->blk_loop.itervar, cur); + sv_setsv(*itersvp, cur); } else #endif @@ -1514,8 +1541,8 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as * they used to */ - SvREFCNT_dec(*cx->blk_loop.itervar); - *cx->blk_loop.itervar = newSVsv(cur); + SvREFCNT_dec(*itersvp); + *itersvp = newSVsv(cur); } if (strEQ(SvPVX(cur), max)) sv_setiv(cur, 0); /* terminate next time */ @@ -1530,11 +1557,9 @@ PP(pp_iter) RETPUSHNO; #ifndef USE_THREADS /* don't risk potential race */ - if (SvREFCNT(*cx->blk_loop.itervar) == 1 - && !SvMAGICAL(*cx->blk_loop.itervar)) - { + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++); + sv_setiv(*itersvp, cx->blk_loop.iterix++); } else #endif @@ -1542,8 +1567,8 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ - SvREFCNT_dec(*cx->blk_loop.itervar); - *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++); + SvREFCNT_dec(*itersvp); + *itersvp = newSViv(cx->blk_loop.iterix++); } RETPUSHYES; } @@ -1552,7 +1577,7 @@ PP(pp_iter) if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; - SvREFCNT_dec(*cx->blk_loop.itervar); + SvREFCNT_dec(*itersvp); if (sv = (SvMAGICAL(av)) ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) @@ -1576,11 +1601,11 @@ PP(pp_iter) } LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = cx->blk_loop.iterix; - LvTARGLEN(lv) = (UV) -1; + LvTARGLEN(lv) = (STRLEN)UV_MAX; sv = (SV*)lv; } - *cx->blk_loop.itervar = SvREFCNT_inc(sv); + *itersvp = SvREFCNT_inc(sv); RETPUSHYES; } @@ -1620,7 +1645,7 @@ PP(pp_subst) if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); PUTBACK; s = SvPV(TARG, len); @@ -1877,7 +1902,7 @@ PP(pp_grepwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(PL_curpm); + SAVEVPTR(PL_curpm); src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); @@ -1895,27 +1920,29 @@ PP(pp_leavesub) PMOP *newpm; I32 gimme; register PERL_CONTEXT *cx; - struct block_sub cxsub; + SV *sv; POPBLOCK(cx,newpm); - POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; if (MARK <= SP) { - if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) { + if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { if (SvTEMP(TOPs)) { *MARK = SvREFCNT_inc(TOPs); FREETMPS; sv_2mortal(*MARK); - } else { + } + else { FREETMPS; *MARK = sv_mortalcopy(TOPs); } - } else + } + else *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); - } else { + } + else { MEXTEND(MARK, 0); *MARK = &PL_sv_undef; } @@ -1931,13 +1958,167 @@ PP(pp_leavesub) } PUTBACK; - POPSUB2(); /* Stack values are safe: release CV and @_ ... */ + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ + PL_curpm = newpm; /* ... and pop $1 et al */ + + LEAVE; + LEAVESUB(sv); + return pop_return(); +} + +/* This duplicates the above code because the above code must not + * get any slower by more conditions */ +PP(pp_leavesublv) +{ + djSP; + SV **mark; + SV **newsp; + PMOP *newpm; + I32 gimme; + register PERL_CONTEXT *cx; + SV *sv; + + POPBLOCK(cx,newpm); + + TAINT_NOT; + + if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { + /* We are an argument to a function or grep(). + * This kind of lvalueness was legal before lvalue + * subroutines too, so be backward compatible: + * cannot report errors. */ + + /* Scalar context *is* possible, on the LHS of -> only, + * as in f()->meth(). But this is not an lvalue. */ + if (gimme == G_SCALAR) + goto temporise; + if (gimme == G_ARRAY) { + if (!CvLVALUE(cx->blk_sub.cv)) + goto temporise_array; + EXTEND_MORTAL(SP - newsp); + for (mark = newsp + 1; mark <= SP; mark++) { + if (SvTEMP(*mark)) + /* empty */ ; + else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY)) + *mark = sv_mortalcopy(*mark); + else { + /* Can be a localized value subject to deletion. */ + PL_tmps_stack[++PL_tmps_ix] = *mark; + (void)SvREFCNT_inc(*mark); + } + } + } + } + else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */ + /* Here we go for robustness, not for speed, so we change all + * the refcounts so the caller gets a live guy. Cannot set + * TEMP, so sv_2mortal is out of question. */ + if (!CvLVALUE(cx->blk_sub.cv)) { + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + } + if (gimme == G_SCALAR) { + MARK = newsp + 1; + EXTEND_MORTAL(1); + if (MARK == SP) { + if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); + DIE(aTHX_ "Can't return a %s from lvalue subroutine", + SvREADONLY(TOPs) ? "readonly value" : "temporary"); + } + else { /* Can be a localized value + * subject to deletion. */ + PL_tmps_stack[++PL_tmps_ix] = *mark; + (void)SvREFCNT_inc(*mark); + } + } + else { /* Should not happen? */ + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); + DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", + (MARK > SP ? "Empty array" : "Array")); + } + SP = MARK; + } + else if (gimme == G_ARRAY) { + EXTEND_MORTAL(SP - newsp); + for (mark = newsp + 1; mark <= SP; mark++) { + if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + /* Might be flattened array after $#array = */ + PUTBACK; + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVE; + LEAVESUB(sv); + DIE(aTHX_ "Can't return %s from lvalue subroutine", + (*mark != &PL_sv_undef) + ? (SvREADONLY(TOPs) + ? "a readonly value" : "a temporary") + : "an uninitialized value"); + } + else { + mortalize: + /* Can be a localized value subject to deletion. */ + PL_tmps_stack[++PL_tmps_ix] = *mark; + (void)SvREFCNT_inc(*mark); + } + } + } + } + else { + if (gimme == G_SCALAR) { + temporise: + MARK = newsp + 1; + if (MARK <= SP) { + if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { + if (SvTEMP(TOPs)) { + *MARK = SvREFCNT_inc(TOPs); + FREETMPS; + sv_2mortal(*MARK); + } + else { + FREETMPS; + *MARK = sv_mortalcopy(TOPs); + } + } + else + *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); + } + else { + MEXTEND(MARK, 0); + *MARK = &PL_sv_undef; + } + SP = MARK; + } + else if (gimme == G_ARRAY) { + temporise_array: + for (MARK = newsp + 1; MARK <= SP; MARK++) { + if (!SvTEMP(*MARK)) { + *MARK = sv_mortalcopy(*MARK); + TAINT_NOT; /* Each item is independent */ + } + } + } + } + PUTBACK; + + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ LEAVE; + LEAVESUB(sv); return pop_return(); } + STATIC CV * S_get_db_sub(pTHX_ SV **svp, CV *cv) { @@ -1965,7 +2146,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) SvUPGRADE(dbsv, SVt_PVIV); SvIOK_on(dbsv); SAVEIV(SvIVX(dbsv)); - SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */ + SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */ } if (CvXSUB(cv)) @@ -2098,7 +2279,7 @@ try_autoload: || !(sv = AvARRAY(av)[0])) { MUTEX_UNLOCK(CvMUTEXP(cv)); - Perl_croak(aTHX_ "no argument for locked method call"); + DIE(aTHX_ "no argument for locked method call"); } } if (SvROK(sv)) @@ -2121,10 +2302,10 @@ try_autoload: while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n", thr, sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR(Perl_unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); } @@ -2163,13 +2344,13 @@ try_autoload: /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); cv = *(CV**)svp; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "entersub: %p already has clone %p:%s\n", thr, cv, SvPEEK((SV*)cv))); CvOWNER(cv) = thr; SvREFCNT_inc(cv); if (CvDEPTH(cv) == 0) - SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } else { /* (2) => grab ownership of cv. (3) => make clone */ @@ -2177,16 +2358,17 @@ try_autoload: CvOWNER(cv) = thr; SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "entersub: %p grabbing %p:%s in stash %s\n", thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? HvNAME(CvSTASH(cv)) : "(none)")); - } else { + } + else { /* Make a new clone. */ CV *clonecv; SvREFCNT_inc(cv); /* don't let it vanish from under us */ MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_S((PerlIO_printf(PerlIO_stderr(), + DEBUG_S((PerlIO_printf(Perl_debug_log, "entersub: %p cloning %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); /* @@ -2204,9 +2386,9 @@ try_autoload: SvREFCNT_inc(cv); } DEBUG_S(if (CvDEPTH(cv) != 0) - PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", CvDEPTH(cv));); - SAVEDESTRUCTOR(unset_cvowner, (void*) cv); + SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } } #endif /* USE_THREADS */ @@ -2223,7 +2405,7 @@ try_autoload: SP--; } PL_stack_sp = mark + 1; - fp3 = (I32(*)(int,int,int)))CvXSUB(cv; + fp3 = (I32(*)(int,int,int))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); @@ -2259,7 +2441,7 @@ try_autoload: } /* We assume first XSUB in &DB::sub is the called one. */ if (PL_curcopdb) { - SAVESPTR(PL_curcop); + SAVEVPTR(PL_curcop); PL_curcop = PL_curcopdb; PL_curcopdb = NULL; } @@ -2295,14 +2477,16 @@ try_autoload: if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ + PERL_STACK_OVERFLOW_CHECK(); if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *av; AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); I32 ix = AvFILLp((AV*)svp[1]); + I32 names_fill = AvFILLp((AV*)svp[0]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { - if (svp[ix] != &PL_sv_undef) { + if (names_fill >= ix && svp[ix] != &PL_sv_undef) { char *name = SvPVX(svp[ix]); if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ || *name == '&') /* anonymous code? */ @@ -2319,6 +2503,9 @@ try_autoload: SvPADMY_on(sv); } } + else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) { + av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); + } else { av_store(newpad, ix, sv = NEWSV(0,0)); SvPADTMP_on(sv); @@ -2347,7 +2534,7 @@ try_autoload: } } #endif /* USE_THREADS */ - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (hasargs) @@ -2357,13 +2544,16 @@ try_autoload: SV** ary; #if 0 - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p entersub preparing @_\n", thr)); #endif av = (AV*)PL_curpad[0]; if (AvREAL(av)) { + /* @_ is normally not REAL--this should only ever + * happen when DB::sub() calls things that modify @_ */ av_clear(av); AvREAL_off(av); + AvREIFY_on(av); } #ifndef USE_THREADS cx->blk_sub.savearray = GvAV(PL_defgv); @@ -2402,7 +2592,7 @@ try_autoload: && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) sub_crush_depth(cv); #if 0 - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p entersub returning %p\n", thr, CvSTART(cv))); #endif RETURNOP(CvSTART(cv)); @@ -2498,25 +2688,46 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { djSP; + SV* sv = TOPs; + + if (SvROK(sv)) { + SV* rsv = SvRV(sv); + if (SvTYPE(rsv) == SVt_PVCV) { + SETs(rsv); + RETURN; + } + } + + SETs(method_common(sv, Null(U32*))); + RETURN; +} + +PP(pp_method_named) +{ + djSP; + SV* sv = cSVOP->op_sv; + U32 hash = SvUVX(sv); + + XPUSHs(method_common(sv, &hash)); + RETURN; +} + +STATIC SV * +S_method_common(pTHX_ SV* meth, U32* hashp) +{ + djSP; SV* sv; SV* ob; GV* gv; HV* stash; char* name; + STRLEN namelen; char* packname; STRLEN packlen; - if (SvROK(TOPs)) { - sv = SvRV(TOPs); - if (SvTYPE(sv) == SVt_PVCV) { - SETs(sv); - RETURN; - } - } - - name = SvPV(TOPs, packlen); + name = SvPV(meth, namelen); sv = *(PL_stack_base + TOPMARK + 1); - + if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) @@ -2536,9 +2747,9 @@ PP(pp_method) : !isIDFIRST(*packname) )) { - DIE(aTHX_ "Can't call method \"%s\" %s", name, - SvOK(sv)? "without a package or object reference" - : "on an undefined value"); + Perl_croak(aTHX_ "Can't call method \"%s\" %s", name, + SvOK(sv) ? "without a package or object reference" + : "on an undefined value"); } stash = gv_stashpvn(packname, packlen, TRUE); goto fetch; @@ -2547,11 +2758,23 @@ PP(pp_method) } if (!ob || !SvOBJECT(ob)) - DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name); + Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", + name); stash = SvSTASH(ob); fetch: + /* shortcut for simple names */ + if (hashp) { + HE* he = hv_fetch_ent(stash, meth, 0, *hashp); + if (he) { + gv = (GV*)HeVAL(he); + if (isGV(gv) && GvCV(gv) && + (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) + return (SV*)GvCV(gv); + } + } + gv = gv_fetchmethod(stash, name); if (!gv) { char* leaf = name; @@ -2565,18 +2788,18 @@ PP(pp_method) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = HvNAME(sep ? PL_curcop->cop_stash : stash); + packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash); packlen = strlen(packname); } else { packname = name; packlen = sep - name; } - DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", - leaf, (int)packlen, packname); + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"", + leaf, packname); } - SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); - RETURN; + return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } #ifdef USE_THREADS @@ -2588,11 +2811,11 @@ unset_cvowner(pTHXo_ void *cvarg) dTHR; #endif /* DEBUGGING */ - DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", + DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); MUTEX_LOCK(CvMUTEXP(cv)); DEBUG_S(if (CvDEPTH(cv) != 0) - PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", CvDEPTH(cv));); assert(thr == CvOWNER(cv)); CvOWNER(cv) = 0;