X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=66d22bcc75edc33716a1219147952ae9d49bb6c3;hb=297b36dcf845fc5195afb0a1d7e83d539bb1d4ed;hp=c15e3a52256010de0d53aba82f031e191f8a61e4;hpb=8b10dff31427fe6416deb7d9925f879108959e53;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index c15e3a5..66d22bc 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,6 +16,7 @@ */ #include "EXTERN.h" +#define PERL_IN_PP_HOT_C #include "perl.h" #ifdef I_UNISTD @@ -25,39 +26,21 @@ /* Hot code. */ #ifdef USE_THREADS -static void -unset_cvowner(void *cvarg) -{ - register CV* cv = (CV *) cvarg; -#ifdef DEBUGGING - dTHR; -#endif /* DEBUGGING */ - - DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n", - thr, cv, SvPEEK((SV*)cv)))); - MUTEX_LOCK(CvMUTEXP(cv)); - DEBUG_L(if (CvDEPTH(cv) != 0) - PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", - CvDEPTH(cv));); - assert(thr == CvOWNER(cv)); - CvOWNER(cv) = 0; - MUTEX_UNLOCK(CvMUTEXP(cv)); - SvREFCNT_dec(cv); -} +static void unset_cvowner(pTHXo_ void *cvarg); #endif /* USE_THREADS */ PP(pp_const) { djSP; - XPUSHs(cSVOP->op_sv); + XPUSHs(cSVOP_sv); RETURN; } PP(pp_nextstate) { - curcop = (COP*)op; + PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; return NORMAL; } @@ -66,10 +49,10 @@ PP(pp_gvsv) { djSP; EXTEND(SP,1); - if (op->op_private & OPpLVAL_INTRO) - PUSHs(save_scalar(cGVOP->op_gv)); + if (PL_op->op_private & OPpLVAL_INTRO) + PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSV(cGVOP->op_gv)); + PUSHs(GvSV(cGVOP_gv)); RETURN; } @@ -78,9 +61,15 @@ PP(pp_null) return NORMAL; } +PP(pp_setstate) +{ + PL_curcop = (COP*)PL_op; + return NORMAL; +} + PP(pp_pushmark) { - PUSHMARK(stack_sp); + PUSHMARK(PL_stack_sp); return NORMAL; } @@ -91,6 +80,8 @@ PP(pp_stringify) char *s; s = SvPV(TOPs,len); sv_setpvn(TARG,s,len); + if (SvUTF8(TOPs) && !IN_BYTE) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -98,7 +89,7 @@ PP(pp_stringify) PP(pp_gv) { djSP; - XPUSHs((SV*)cGVOP->op_gv); + XPUSHs((SV*)cGVOP_gv); RETURN; } @@ -116,13 +107,12 @@ PP(pp_and) PP(pp_sassign) { djSP; dPOPTOPssrl; - MAGIC *mg; - if (op->op_private & OPpASSIGN_BACKWARDS) { + if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; temp = left; left = right; right = temp; } - if (tainting && tainted && !SvTAINTED(left)) + if (PL_tainting && PL_tainted && !SvTAINTED(left)) TAINT_NOT; SvSetMagicSV(right, left); SETs(right); @@ -133,18 +123,18 @@ PP(pp_cond_expr) { djSP; if (SvTRUEx(POPs)) - RETURNOP(cCONDOP->op_true); + RETURNOP(cLOGOP->op_other); else - RETURNOP(cCONDOP->op_false); + RETURNOP(cLOGOP->op_next); } PP(pp_unstack) { I32 oldsave; TAINT_NOT; /* Each statement is presumed innocent */ - stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; + PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; - oldsave = scopestack[scopestack_ix - 1]; + oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); return NORMAL; } @@ -156,21 +146,56 @@ PP(pp_concat) dPOPTOPssrl; STRLEN len; char *s; + bool left_utf = DO_UTF8(left); + bool right_utf = DO_UTF8(right); + if (TARG != left) { + if (right_utf && !left_utf) + sv_utf8_upgrade(left); s = SvPV(left,len); + SvUTF8_off(TARG); + if (TARG == right) { + if (left_utf && !right_utf) + sv_utf8_upgrade(right); + sv_insert(TARG, 0, 0, s, len); + if (left_utf || right_utf) + SvUTF8_on(TARG); + SETs(TARG); + RETURN; + } sv_setpvn(TARG,s,len); } - else if (SvGMAGICAL(TARG)) + else if (SvGMAGICAL(TARG)) { mg_get(TARG); + if (right_utf && !left_utf) + sv_utf8_upgrade(left); + } else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { sv_setpv(TARG, ""); /* Suppress warning. */ s = SvPV_force(TARG, len); } + if (left_utf && !right_utf) + sv_utf8_upgrade(right); s = SvPV(right,len); - if (SvOK(TARG)) + if (SvOK(TARG)) { +#if defined(PERL_Y2KWARN) + if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { + 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_Y2K, "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 */ + if (left_utf || right_utf) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -180,12 +205,12 @@ PP(pp_padsv) { djSP; dTARGET; XPUSHs(TARG); - if (op->op_flags & OPf_MOD) { - if (op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(curpad[op->op_targ]); - else if (op->op_private & OPpDEREF) { + if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_private & OPpLVAL_INTRO) + SAVECLEARSV(PL_curpad[PL_op->op_targ]); + else if (PL_op->op_private & OPpDEREF) { PUTBACK; - vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF); + vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF); SPAGAIN; } } @@ -194,7 +219,19 @@ PP(pp_padsv) PP(pp_readline) { - last_in_gv = (GV*)(*stack_sp--); + tryAMAGICunTARGET(iter, 0); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { + if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) + PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); + else { + dSP; + XPUSHs((SV*)PL_last_in_gv); + PUTBACK; + pp_rv2gv(); + PL_last_in_gv = (GV*)(*PL_stack_sp--); + } + } return do_readline(); } @@ -212,8 +249,8 @@ PP(pp_preinc) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + DIE(aTHX_ PL_no_modify); + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); @@ -249,10 +286,14 @@ PP(pp_add) PP(pp_aelemfast) { djSP; - AV *av = GvAV((GV*)cSVOP->op_sv); - SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD); + 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); EXTEND(SP, 1); - PUSHs(svp ? *svp : &sv_undef); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -277,10 +318,10 @@ PP(pp_pushre) SV* sv = sv_newmortal(); sv_upgrade(sv, SVt_PVLV); LvTYPE(sv) = '/'; - Copy(&op, &LvTARGOFF(sv), 1, OP*); + Copy(&PL_op, &LvTARGOFF(sv), 1, OP*); XPUSHs(sv); #else - XPUSHs((SV*)op); + XPUSHs((SV*)PL_op); #endif RETURN; } @@ -294,12 +335,13 @@ PP(pp_print) IO *io; register PerlIO *fp; MAGIC *mg; + STRLEN n_a; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; else - gv = defoutgv; - if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + gv = PL_defoutgv; + if ((mg = SvTIED_mg((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... @@ -310,10 +352,10 @@ PP(pp_print) ++SP; } PUSHMARK(MARK - 1); - *MARK = mg->mg_obj; + *MARK = SvTIED_obj((SV*)gv, mg); PUTBACK; ENTER; - perl_call_method("PRINT", G_SCALAR); + call_method("PRINT", G_SCALAR); LEAVE; SPAGAIN; MARK = ORIGMARK + 1; @@ -322,36 +364,39 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if (dowarn) { + if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); - warn("Filehandle %s never opened", SvPV(sv,na)); + gv_efullname3(sv, gv, Nullch); + Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", + SvPV(sv,n_a)); } - SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (dowarn) { - SV* sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); - if (IoIFP(io)) - warn("Filehandle %s opened only for input", SvPV(sv,na)); - else - warn("print on closed filehandle %s", SvPV(sv,na)); + if (ckWARN2(WARN_CLOSED, WARN_IO)) { + if (IoIFP(io)) { + SV* sv = sv_newmortal(); + gv_efullname3(sv, gv, Nullch); + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", + SvPV(sv,n_a)); + } + else if (ckWARN(WARN_CLOSED)) + report_closed_fh(gv, io, "print", "filehandle"); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; } else { MARK++; - if (ofslen) { + if (PL_ofslen) { while (MARK <= SP) { if (!do_print(*MARK, fp)) break; MARK++; if (MARK <= SP) { - if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) { + if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) { MARK--; break; } @@ -368,8 +413,8 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (orslen) - if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp)) + if (PL_orslen) + if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp)) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) @@ -378,35 +423,37 @@ PP(pp_print) } } SP = ORIGMARK; - PUSHs(&sv_yes); + PUSHs(&PL_sv_yes); RETURN; just_say_no: SP = ORIGMARK; - PUSHs(&sv_undef); + PUSHs(&PL_sv_undef); RETURN; } PP(pp_rv2av) { - djSP; dPOPss; + djSP; dTOPss; AV *av; if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_av); + av = (AV*)SvRV(sv); if (SvTYPE(av) != SVt_PVAV) - DIE("Not an ARRAY reference"); - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + DIE(aTHX_ "Not an ARRAY reference"); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } else { if (SvTYPE(sv) == SVt_PVAV) { av = (AV*)sv; - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } @@ -415,6 +462,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -422,27 +470,43 @@ PP(pp_rv2av) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "an ARRAY"); - if (dowarn) - warn(warn_uninit); - if (GIMME == G_ARRAY) + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_usym, "an ARRAY"); + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); + if (GIMME == G_ARRAY) { + (void)POPs; RETURN; - RETPUSHUNDEF; + } + RETSETUNDEF; } - sym = SvPV(sv,na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "an ARRAY"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); - } else { + sym = SvPV(sv,len); + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) + { + RETSETUNDEF; + } + } + else { + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_symref, sym, "an ARRAY"); + gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); + } + } + else { gv = (GV*)sv; } av = GvAVn(gv); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) av = save_ary(gv); - if (op->op_flags & OPf_REF) { - PUSHs((SV*)av); + if (PL_op->op_flags & OPf_REF) { + SETs((SV*)av); RETURN; } } @@ -450,12 +514,13 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; + (void)POPs; /* XXXX May be optimized away? */ EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); - SP[i+1] = (svp) ? *svp : &sv_undef; + SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { @@ -466,7 +531,7 @@ PP(pp_rv2av) else { dTARGET; I32 maxarg = AvFILL(av) + 1; - PUSHi(maxarg); + SETi(maxarg); } RETURN; } @@ -478,10 +543,12 @@ PP(pp_rv2hv) if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_hv); + hv = (HV*)SvRV(sv); if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) - DIE("Not a HASH reference"); - if (op->op_flags & OPf_REF) { + DIE(aTHX_ "Not a HASH reference"); + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -489,7 +556,7 @@ PP(pp_rv2hv) else { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { hv = (HV*)sv; - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -499,6 +566,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -506,28 +574,42 @@ PP(pp_rv2hv) goto wasref; } if (!SvOK(sv)) { - if (op->op_flags & OPf_REF || - op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a HASH"); - if (dowarn) - warn(warn_uninit); + if (PL_op->op_flags & OPf_REF || + PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_usym, "a HASH"); + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); if (GIMME == G_ARRAY) { SP--; RETURN; } RETSETUNDEF; } - sym = SvPV(sv,na); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a HASH"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); - } else { + sym = SvPV(sv,len); + if ((PL_op->op_flags & OPf_SPECIAL) && + !(PL_op->op_flags & OPf_MOD)) + { + gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) + { + RETSETUNDEF; + } + } + else { + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_symref, sym, "a HASH"); + gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); + } + } + else { gv = (GV*)sv; } hv = GvHVn(gv); - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) hv = save_hash(gv); - if (op->op_flags & OPf_REF) { + if (PL_op->op_flags & OPf_REF) { SETs((SV*)hv); RETURN; } @@ -535,15 +617,16 @@ PP(pp_rv2hv) } if (GIMME == G_ARRAY) { /* array wanted */ - *stack_sp = (SV*)hv; - return do_kv(ARGS); + *PL_stack_sp = (SV*)hv; + return do_kv(); } else { dTARGET; - /* This bit is OK even when hv is really an AV */ + if (SvTYPE(hv) == SVt_PVAV) + hv = avhv_keys((AV*)hv); if (HvFILL(hv)) - sv_setpvf(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); @@ -552,12 +635,98 @@ PP(pp_rv2hv) } } +STATIC int +S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, + SV **lastrelem) +{ + OP *leftop; + I32 i; + + leftop = ((BINOP*)PL_op)->op_last; + assert(leftop); + assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST); + leftop = ((LISTOP*)leftop)->op_first; + assert(leftop); + /* Skip PUSHMARK and each element already assigned to. */ + for (i = lelem - firstlelem; i > 0; i--) { + leftop = leftop->op_sibling; + assert(leftop); + } + if (leftop->op_type != OP_RV2HV) + return 0; + + /* pseudohash */ + if (av_len(ary) > 0) + av_fill(ary, 0); /* clear all but the fields hash */ + if (lastrelem >= relem) { + while (relem < lastrelem) { /* gobble up all the rest */ + SV *tmpstr; + assert(relem[0]); + assert(relem[1]); + /* Avoid a memory leak when avhv_store_ent dies. */ + tmpstr = sv_newmortal(); + sv_setsv(tmpstr,relem[1]); /* value */ + relem[1] = tmpstr; + if (avhv_store_ent(ary,relem[0],tmpstr,0)) + (void)SvREFCNT_inc(tmpstr); + if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + relem += 2; + TAINT_NOT; + } + } + if (relem == lastrelem) + return 1; + return 2; +} + +STATIC void +S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) +{ + if (*relem) { + SV *tmpstr; + if (ckWARN(WARN_MISC)) { + if (relem == firstrelem && + SvROK(*relem) && + (SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV)) + { + Perl_warner(aTHX_ WARN_MISC, + "Reference found where even-sized list expected"); + } + else + Perl_warner(aTHX_ WARN_MISC, + "Odd number of elements in hash assignment"); + } + if (SvTYPE(hash) == SVt_PVAV) { + /* pseudohash */ + tmpstr = sv_newmortal(); + if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) + (void)SvREFCNT_inc(tmpstr); + if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + } + else { + HE *didstore; + tmpstr = NEWSV(29,0); + didstore = hv_store_ent(hash,*relem,tmpstr,0); + if (SvMAGICAL(hash)) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + sv_2mortal(tmpstr); + } + } + TAINT_NOT; + } +} + PP(pp_aassign) { djSP; - SV **lastlelem = stack_sp; - SV **lastrelem = stack_base + POPMARK; - SV **firstrelem = stack_base + POPMARK + 1; + SV **lastlelem = PL_stack_sp; + SV **lastrelem = PL_stack_base + POPMARK; + SV **firstrelem = PL_stack_base + POPMARK + 1; SV **firstlelem = lastrelem + 1; register SV **relem; @@ -571,26 +740,28 @@ PP(pp_aassign) I32 i; int magic; - delaymagic = DM_DELAY; /* catch simultaneous items */ + PL_delaymagic = DM_DELAY; /* catch simultaneous items */ /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ - if (op->op_private & OPpASSIGN_COMMON) { - for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ - if (sv = *relem) { + if (PL_op->op_private & (OPpASSIGN_COMMON)) { + EXTEND_MORTAL(lastrelem - firstrelem + 1); + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if ((sv = *relem)) { TAINT_NOT; /* Each item is independent */ - *relem = sv_mortalcopy(sv); + *relem = sv_mortalcopy(sv); } - } + } } relem = firstrelem; lelem = firstlelem; ary = Null(AV*); hash = Null(HV*); + while (lelem <= lastlelem) { TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; @@ -598,7 +769,19 @@ PP(pp_aassign) case SVt_PVAV: ary = (AV*)sv; magic = SvMAGICAL(ary) != 0; - + if (PL_op->op_private & OPpASSIGN_HASH) { + switch (do_maybe_phash(ary, lelem, firstlelem, relem, + lastrelem)) + { + case 0: + goto normal_array; + case 1: + do_oddball((HV*)ary, relem, firstrelem); + } + relem = lastrelem + 1; + break; + } + normal_array: av_clear(ary); av_extend(ary, lastrelem - relem); i = 0; @@ -613,12 +796,12 @@ PP(pp_aassign) if (SvSMAGICAL(sv)) mg_set(sv); if (!didstore) - SvREFCNT_dec(sv); + sv_2mortal(sv); } TAINT_NOT; } break; - case SVt_PVHV: { + case SVt_PVHV: { /* normal hash */ SV *tmpstr; hash = (HV*)sv; @@ -626,12 +809,11 @@ PP(pp_aassign) hv_clear(hash); while (relem < lastrelem) { /* gobble up all the rest */ - STRLEN len; HE *didstore; if (*relem) sv = *(relem++); else - sv = &sv_no, relem++; + sv = &PL_sv_no, relem++; tmpstr = NEWSV(29,0); if (*relem) sv_setsv(tmpstr,*relem); /* value */ @@ -641,105 +823,94 @@ PP(pp_aassign) if (SvSMAGICAL(tmpstr)) mg_set(tmpstr); if (!didstore) - SvREFCNT_dec(tmpstr); + sv_2mortal(tmpstr); } TAINT_NOT; } - if (relem == lastrelem && dowarn) { - if (relem == firstrelem && - SvROK(*relem) && - ( SvTYPE(SvRV(*relem)) == SVt_PVAV || - SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) - warn("Reference found where even-sized list expected"); - else - warn("Odd number of elements in hash assignment"); + if (relem == lastrelem) { + do_oddball(hash, relem, firstrelem); + relem++; } } break; default: - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && curcop != &compiling) { - if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no) - DIE(no_modify); - if (relem <= lastrelem) - relem++; - break; - } - if (SvROK(sv)) - sv_unref(sv); + if (SvIMMORTAL(sv)) { + if (relem <= lastrelem) + relem++; + break; } if (relem <= lastrelem) { sv_setsv(sv, *relem); *(relem++) = sv; } else - sv_setsv(sv, &sv_undef); + sv_setsv(sv, &PL_sv_undef); SvSETMAGIC(sv); break; } } - if (delaymagic & ~DM_DELAY) { - if (delaymagic & DM_UID) { + if (PL_delaymagic & ~DM_DELAY) { + if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - (void)setresuid(uid,euid,(Uid_t)-1); + (void)setresuid(PL_uid,PL_euid,(Uid_t)-1); #else # ifdef HAS_SETREUID - (void)setreuid(uid,euid); + (void)setreuid(PL_uid,PL_euid); # else # ifdef HAS_SETRUID - if ((delaymagic & DM_UID) == DM_RUID) { - (void)setruid(uid); - delaymagic &= ~DM_RUID; + if ((PL_delaymagic & DM_UID) == DM_RUID) { + (void)setruid(PL_uid); + PL_delaymagic &= ~DM_RUID; } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID - if ((delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(uid); - delaymagic &= ~DM_EUID; + if ((PL_delaymagic & DM_UID) == DM_EUID) { + (void)seteuid(PL_uid); + PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ - if (delaymagic & DM_UID) { - if (uid != euid) - DIE("No setreuid available"); - (void)setuid(uid); + if (PL_delaymagic & DM_UID) { + if (PL_uid != PL_euid) + DIE(aTHX_ "No setreuid available"); + (void)PerlProc_setuid(PL_uid); } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ - uid = (int)getuid(); - euid = (int)geteuid(); + PL_uid = PerlProc_getuid(); + PL_euid = PerlProc_geteuid(); } - if (delaymagic & DM_GID) { + if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - (void)setresgid(gid,egid,(Gid_t)-1); + (void)setresgid(PL_gid,PL_egid,(Gid_t)-1); #else # ifdef HAS_SETREGID - (void)setregid(gid,egid); + (void)setregid(PL_gid,PL_egid); # else # ifdef HAS_SETRGID - if ((delaymagic & DM_GID) == DM_RGID) { - (void)setrgid(gid); - delaymagic &= ~DM_RGID; + if ((PL_delaymagic & DM_GID) == DM_RGID) { + (void)setrgid(PL_gid); + PL_delaymagic &= ~DM_RGID; } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID - if ((delaymagic & DM_GID) == DM_EGID) { - (void)setegid(gid); - delaymagic &= ~DM_EGID; + if ((PL_delaymagic & DM_GID) == DM_EGID) { + (void)setegid(PL_gid); + PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ - if (delaymagic & DM_GID) { - if (gid != egid) - DIE("No setregid available"); - (void)setgid(gid); + if (PL_delaymagic & DM_GID) { + if (PL_gid != PL_egid) + DIE(aTHX_ "No setregid available"); + (void)PerlProc_setgid(PL_gid); } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ - gid = (int)getgid(); - egid = (int)getegid(); + PL_gid = PerlProc_getgid(); + PL_egid = PerlProc_getegid(); } - tainting |= (uid && (euid != uid || egid != gid)); + PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } - delaymagic = 0; + PL_delaymagic = 0; gimme = GIMME_V; if (gimme == G_VOID) @@ -756,11 +927,21 @@ PP(pp_aassign) SP = firstrelem + (lastlelem - firstlelem); lelem = firstlelem + (relem - firstrelem); while (relem <= SP) - *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef; + *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; } RETURN; } +PP(pp_qr) +{ + djSP; + register PMOP *pm = cPMOP; + SV *rv = sv_newmortal(); + SV *sv = newSVrv(rv, "Regexp"); + sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); + RETURNX(PUSHs(rv)); +} + PP(pp_match) { djSP; dTARG; @@ -769,17 +950,18 @@ PP(pp_match) register char *s; char *strend; I32 global; - I32 safebase; - char *truebase; + I32 r_flags = REXEC_CHECKED; + char *truebase; /* Start of string */ register REGEXP *rx = pm->op_pmregexp; + bool rxtainted; I32 gimme = GIMME; STRLEN len; I32 minmatch = 0; - I32 oldsave = savestack_ix; + I32 oldsave = PL_savestack_ix; I32 update_minmatch = 1; - SV *screamer; + I32 had_zerolen = 0; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) TARG = POPs; else { TARG = DEFSV; @@ -789,7 +971,9 @@ PP(pp_match) s = SvPV(TARG, len); strend = s + len; if (!s) - DIE("panic: do_match"); + DIE(aTHX_ "panic: do_match"); + rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; if (pm->op_pmdynflags & PMdf_USED) { @@ -799,94 +983,66 @@ PP(pp_match) RETPUSHNO; } - if (!rx->prelen && curpm) { - pm = curpm; + if (!rx->prelen && PL_curpm) { + pm = PL_curpm; rx = pm->op_pmregexp; } if (rx->minlen > len) goto failure; - screamer = ( (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) - ? TARG : Nullsv); truebase = t = s; - if (global = pm->op_pmflags & PMf_GLOBAL) { - rx->startp[0] = 0; + + /* XXXX What part of this is needed with true \G-support? */ + if ((global = pm->op_pmflags & PMf_GLOBAL)) { + rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, 'g'); if (mg && mg->mg_len >= 0) { - rx->endp[0] = rx->startp[0] = s + mg->mg_len; + if (!(rx->reganch & ROPT_GPOS_SEEN)) + rx->endp[0] = rx->startp[0] = mg->mg_len; + else if (rx->reganch & ROPT_ANCH_GPOS) { + r_flags |= REXEC_IGNOREPOS; + rx->endp[0] = rx->startp[0] = mg->mg_len; + } minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; } } } - if (!rx->nparens && !global) - gimme = G_SCALAR; /* accidental array context? */ - safebase = (((gimme == G_ARRAY) || global || !rx->nparens) - && !sawampersand); - safebase = safebase ? 0 : REXEC_COPY_STR ; + if ((gimme != G_ARRAY && !global && rx->nparens) + || SvTEMP(TARG) || PL_sawampersand) + r_flags |= REXEC_COPY_STR; + if (SvSCREAM(TARG)) + r_flags |= REXEC_SCREAM; + if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } play_it_again: - if (global && rx->startp[0]) { - t = s = rx->endp[0]; + if (global && rx->startp[0] != -1) { + t = s = rx->endp[0] + truebase; if ((s + rx->minlen) > strend) goto nope; if (update_minmatch++) - minmatch = (s == rx->startp[0]); - } - if (rx->check_substr) { - if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */ - if ( screamer ) { - I32 p = -1; - - if (screamfirst[BmRARE(rx->check_substr)] < 0) - goto nope; - else if (!(s = screaminstr(TARG, rx->check_substr, - rx->check_offset_min, 0, &p, 0))) - goto nope; - else if ((rx->reganch & ROPT_CHECK_ALL) - && !sawampersand && !SvTAIL(rx->check_substr)) - goto yup; - } - else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, - (unsigned char*)strend, - rx->check_substr))) - goto nope; - else if ((rx->reganch & ROPT_CHECK_ALL) && !sawampersand) - goto yup; - if (s && rx->check_offset_max < t - s) { - ++BmUSEFUL(rx->check_substr); - s -= rx->check_offset_max; - } - else - s = t; - } - /* Now checkstring is fixed, i.e. at fixed offset from the - beginning of match, and the match is anchored at s. */ - else if (!multiline) { /* Anchored near beginning of string. */ - I32 slen; - if (*SvPVX(rx->check_substr) != s[rx->check_offset_min] - || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), - s + rx->check_offset_min, slen))) - goto nope; - } - if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0 - && rx->check_substr == rx->float_substr) { - SvREFCNT_dec(rx->check_substr); - rx->check_substr = Nullsv; /* opt is being useless */ - rx->float_substr = Nullsv; - } - } - if (regexec_flags(rx, s, strend, truebase, minmatch, - screamer, NULL, safebase)) + minmatch = had_zerolen; + } + if (rx->reganch & RE_USE_INTUIT) { + s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + + if (!s) + goto nope; + if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM))) + && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ + goto yup; + } + if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { - curpm = pm; + PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmdynflags |= PMdf_USED; goto gotcha; @@ -896,6 +1052,8 @@ play_it_again: /*NOTREACHED*/ gotcha: + if (rxtainted) + RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { I32 iters, i, len; @@ -911,19 +1069,25 @@ play_it_again: for (i = !i; i <= iters; i++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ - if ((s = rx->startp[i]) && rx->endp[i] ) { - len = rx->endp[i] - s; + if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { + len = rx->endp[i] - rx->startp[i]; + s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); + if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + SvUTF8_on(*SP); + sv_utf8_downgrade(*SP, TRUE); + } } } if (global) { - truebase = rx->subbeg; - strend = rx->subend; - if (rx->startp[0] && rx->startp[0] == rx->endp[0]) - ++rx->endp[0]; + had_zerolen = (rx->startp[0] != -1 + && rx->startp[0] == rx->endp[0]); PUTBACK; /* EVAL blocks may use stack */ + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; } + else if (!iters) + XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; } @@ -936,8 +1100,8 @@ play_it_again: sv_magic(TARG, (SV*)0, 'g', Nullch, 0); mg = mg_find(TARG, 'g'); } - if (rx->startp[0]) { - mg->mg_len = rx->endp[0] - rx->subbeg; + if (rx->startp[0] != -1) { + mg->mg_len = rx->endp[0]; if (rx->startp[0] == rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else @@ -948,37 +1112,42 @@ play_it_again: RETPUSHYES; } -yup: /* Confirmed by check_substr */ +yup: /* Confirmed by INTUIT */ + if (rxtainted) + RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); - ++BmUSEFUL(rx->check_substr); - curpm = pm; + PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmdynflags |= PMdf_USED; - Safefree(rx->subbase); - rx->subbase = Nullch; + if (RX_MATCH_COPIED(rx)) + Safefree(rx->subbeg); + RX_MATCH_COPIED_off(rx); + rx->subbeg = Nullch; if (global) { rx->subbeg = truebase; - rx->subend = strend; - rx->startp[0] = s; - rx->endp[0] = s + SvCUR(rx->check_substr); + rx->startp[0] = s - truebase; + rx->endp[0] = s - truebase + rx->minlen; + rx->sublen = strend - truebase; goto gotcha; - } - if (sawampersand) { - char *tmps; + } + if (PL_sawampersand) { + I32 off; - tmps = rx->subbase = savepvn(t, strend-t); - rx->subbeg = tmps; - rx->subend = tmps + (strend-t); - tmps = rx->startp[0] = tmps + (s - t); - rx->endp[0] = tmps + SvCUR(rx->check_substr); + rx->subbeg = savepvn(t, strend - t); + rx->sublen = strend - t; + RX_MATCH_COPIED_on(rx); + off = rx->startp[0] = s - t; + rx->endp[0] = off + rx->minlen; } + else { /* startp/endp are used by @- @+. */ + rx->startp[0] = s - truebase; + rx->endp[0] = s - truebase + rx->minlen; + } + rx->nparens = rx->lastparen = 0; /* used by @- and @+ */ LEAVE_SCOPE(oldsave); RETPUSHYES; nope: - if (rx->check_substr) - ++BmUSEFUL(rx->check_substr); - ret_no: if (global && !(pm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { @@ -994,24 +1163,24 @@ ret_no: } OP * -do_readline(void) +Perl_do_readline(pTHX) { dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; - register IO *io = GvIO(last_in_gv); - register I32 type = op->op_type; + register IO *io = GvIO(PL_last_in_gv); + register I32 type = PL_op->op_type; I32 gimme = GIMME_V; MAGIC *mg; - if (SvRMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { + if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) { PUSHMARK(SP); - XPUSHs(mg->mg_obj); + XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; ENTER; - perl_call_method("READLINE", gimme); + call_method("READLINE", gimme); LEAVE; SPAGAIN; if (gimme == G_SCALAR) @@ -1024,17 +1193,19 @@ do_readline(void) if (!fp) { if (IoFLAGS(io) & IOf_ARGV) { if (IoFLAGS(io) & IOf_START) { - IoFLAGS(io) &= ~IOf_START; IoLINES(io) = 0; - if (av_len(GvAVn(last_in_gv)) < 0) { - SV *tmpstr = newSVpv("-", 1); /* assume stdin */ - av_push(GvAVn(last_in_gv), tmpstr); + 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)); + fp = IoIFP(io); + goto have_fp; } } - fp = nextargv(last_in_gv); + fp = nextargv(PL_last_in_gv); if (!fp) { /* Note: fp != IoIFP(io) */ - (void)do_close(last_in_gv, FALSE); /* now it does*/ - IoFLAGS(io) |= IOf_START; + (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } else if (type == OP_GLOB) { @@ -1126,6 +1297,11 @@ do_readline(void) } } #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 "); @@ -1143,7 +1319,7 @@ do_readline(void) #endif /* !OS2 */ #else /* !DOSISH */ #if defined(CSH) - sv_setpvn(tmpcmd, cshname, cshlen); + sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); sv_catsv(tmpcmd, tmpglob); sv_catpv(tmpcmd, "' 2>/dev/null |"); @@ -1157,8 +1333,9 @@ do_readline(void) #endif #endif /* !CSH */ #endif /* !DOSISH */ - (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, 0, 0, Nullfp); +#endif /* MACOS_TRADITIONAL */ + (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), + FALSE, O_RDONLY, 0, Nullfp); fp = IoIFP(io); #endif /* !VMS */ LEAVE; @@ -1166,16 +1343,32 @@ do_readline(void) } else if (type == OP_GLOB) SP--; + else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ + && (IoTYPE(io) == '>' || fp == PerlIO_stdout() + || fp == PerlIO_stderr())) + { + SV* sv = sv_newmortal(); + gv_efullname3(sv, PL_last_in_gv, Nullch); + Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", + SvPV_nolen(sv)); + } } if (!fp) { - if (dowarn && io && !(IoFLAGS(io) & IOf_START)) - warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); + if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + if (type == OP_GLOB) + Perl_warner(aTHX_ WARN_GLOB, + "glob failed (can't start child: %s)", + Strerror(errno)); + else + report_closed_fh(PL_last_in_gv, io, "readline", "filehandle"); + } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } RETURN; } + have_fp: if (gimme == G_SCALAR) { sv = TARG; if (SvROK(sv)) @@ -1193,19 +1386,30 @@ do_readline(void) sv = sv_2mortal(NEWSV(57, 80)); offset = 0; } + +/* delay EOF state for a snarfed empty file */ +#define SNARF_EOF(gimme,rs,io,sv) \ + (gimme != G_SCALAR || SvCUR(sv) \ + || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) + for (;;) { - if (!sv_gets(sv, fp, offset)) { + if (!sv_gets(sv, fp, offset) + && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) + { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(last_in_gv); + fp = nextargv(PL_last_in_gv); if (fp) continue; - (void)do_close(last_in_gv, FALSE); - IoFLAGS(io) |= IOf_START; + (void)do_close(PL_last_in_gv, FALSE); } else if (type == OP_GLOB) { - if (do_close(last_in_gv, FALSE) & ~0xFF) - warn("internal error: glob failed"); + if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { + Perl_warner(aTHX_ WARN_GLOB, + "glob failed (child exited with status %d%s)", + (int)(STATUS_CURRENT >> 8), + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + } } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1219,14 +1423,15 @@ do_readline(void) SvTAINTED_on(sv); } IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { char *tmps; - if (SvCUR(sv) > 0 && SvCUR(rs) > 0) { + if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { tmps = SvEND(sv) - 1; - if (*tmps == *SvPVX(rs)) { + if (*tmps == *SvPVX(PL_rs)) { *tmps = '\0'; SvCUR(sv)--; } @@ -1235,7 +1440,7 @@ do_readline(void) if (!isALPHA(*tmps) && !isDIGIT(*tmps) && strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) break; - if (*tmps && PerlLIO_stat(SvPVX(sv), &statbuf) < 0) { + if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } @@ -1264,7 +1469,7 @@ PP(pp_enter) { djSP; register PERL_CONTEXT *cx; - I32 gimme = OP_GIMME(op, -1); + I32 gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { if (cxstack_ix >= 0) @@ -1288,25 +1493,30 @@ PP(pp_helem) SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = op->op_flags & OPf_MOD; - U32 defer = op->op_private & OPpLVAL_DEFER; + U32 lval = PL_op->op_flags & OPf_MOD; + U32 defer = PL_op->op_private & OPpLVAL_DEFER; + SV *sv; if (SvTYPE(hv) == SVt_PVHV) { he = hv_fetch_ent(hv, keysv, lval && !defer, 0); svp = he ? &HeVAL(he) : 0; } else if (SvTYPE(hv) == SVt_PVAV) { + if (PL_op->op_private & OPpLVAL_INTRO) + DIE(aTHX_ "Can't localize pseudo-hash element"); svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0); } else { RETPUSHUNDEF; } if (lval) { - if (!svp || *svp == &sv_undef) { + if (!svp || *svp == &PL_sv_undef) { SV* lv; SV* key2; - if (!defer) - DIE(no_helem, SvPV(keysv, na)); + if (!defer) { + STRLEN n_a; + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); + } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -1317,16 +1527,25 @@ PP(pp_helem) PUSHs(lv); RETURN; } - if (op->op_private & OPpLVAL_INTRO) { + if (PL_op->op_private & OPpLVAL_INTRO) { if (HvNAME(hv) && isGV(*svp)) - save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL)); + save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); else save_helem(hv, keysv, svp); } - else if (op->op_private & OPpDEREF) - vivify_ref(*svp, op->op_private & OPpDEREF); - } - PUSHs(svp ? *svp : &sv_undef); + else if (PL_op->op_private & OPpDEREF) + vivify_ref(*svp, PL_op->op_private & OPpDEREF); + } + sv = (svp ? *svp : &PL_sv_undef); + /* This makes C possible. + * Pushing the magical RHS on to the stack is useless, since + * that magic is soon destined to be misled by the local(), + * and thus the later pp_sassign() will fail to mg_get() the + * old value. This should also cure problems with delayed + * mg_get()s. GSAR 98-07-03 */ + if (!lval && SvGMAGICAL(sv)) + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } @@ -1339,14 +1558,14 @@ PP(pp_leave) PMOP *newpm; I32 gimme; - if (op->op_flags & OPf_SPECIAL) { + if (PL_op->op_flags & OPf_SPECIAL) { cx = &cxstack[cxstack_ix]; - cx->blk_oldpm = curpm; /* fake block should preserve $1 et al */ + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ } POPBLOCK(cx,newpm); - gimme = OP_GIMME(op, -1); + gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { if (cxstack_ix >= 0) gimme = cxstack[cxstack_ix].blk_gimme; @@ -1366,7 +1585,7 @@ PP(pp_leave) *MARK = sv_mortalcopy(TOPs); else { MEXTEND(mark,0); - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } SP = MARK; } @@ -1379,7 +1598,7 @@ PP(pp_leave) } } } - curpm = newpm; /* Don't pop $1 et al till now */ + PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; @@ -1392,25 +1611,79 @@ PP(pp_iter) register PERL_CONTEXT *cx; SV* sv; AV* av; + SV **itersvp; EXTEND(SP, 1); cx = &cxstack[cxstack_ix]; - if (cx->cx_type != CXt_LOOP) - DIE("panic: pp_iter"); + if (CxTYPE(cx) != CXt_LOOP) + DIE(aTHX_ "panic: pp_iter"); + itersvp = CxITERVAR(cx); av = cx->blk_loop.iterary; - if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av))) + if (SvTYPE(av) != SVt_PVAV) { + /* iterate ($min .. $max) */ + if (cx->blk_loop.iterlval) { + /* string increment */ + register SV* cur = cx->blk_loop.iterlval; + STRLEN maxlen; + char *max = SvPV((SV*)av, maxlen); + if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { +#ifndef USE_THREADS /* don't risk potential race */ + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { + /* safe to reuse old SV */ + sv_setsv(*itersvp, cur); + } + else +#endif + { + /* 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(*itersvp); + *itersvp = newSVsv(cur); + } + if (strEQ(SvPVX(cur), max)) + sv_setiv(cur, 0); /* terminate next time */ + else + sv_inc(cur); + RETPUSHYES; + } + RETPUSHNO; + } + /* integer increment */ + if (cx->blk_loop.iterix > cx->blk_loop.itermax) + RETPUSHNO; + +#ifndef USE_THREADS /* don't risk potential race */ + if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { + /* safe to reuse old SV */ + sv_setiv(*itersvp, cx->blk_loop.iterix++); + } + else +#endif + { + /* 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(*itersvp); + *itersvp = newSViv(cx->blk_loop.iterix++); + } + RETPUSHYES; + } + + /* iterate array */ + 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) - : AvARRAY(av)[++cx->blk_loop.iterix]) + if ((sv = SvMAGICAL(av) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + : AvARRAY(av)[++cx->blk_loop.iterix])) SvTEMP_off(sv); else - sv = &sv_undef; - if (av != curstack && SvIMMORTAL(sv)) { + sv = &PL_sv_undef; + if (av != PL_curstack && SvIMMORTAL(sv)) { SV *lv = cx->blk_loop.iterlval; if (lv && SvREFCNT(lv) > 1) { SvREFCNT_dec(lv); @@ -1426,11 +1699,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; } @@ -1452,17 +1725,15 @@ PP(pp_subst) bool once; bool rxtainted; char *orig; - I32 safebase; + I32 r_flags; register REGEXP *rx = pm->op_pmregexp; STRLEN len; int force_on_match = 0; - I32 oldsave = savestack_ix; - I32 update_minmatch = 1; - SV *screamer; + I32 oldsave = PL_savestack_ix; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; - if (op->op_flags & OPf_STACKED) + if (PL_op->op_flags & OPf_STACKED) TARG = POPs; else { TARG = DEFSV; @@ -1471,73 +1742,53 @@ PP(pp_subst) if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) - croak(no_modify); + DIE(aTHX_ PL_no_modify); PUTBACK; s = SvPV(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; - rxtainted = tainted << 1; + rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); + if (PL_tainted) + rxtainted |= 2; TAINT_NOT; force_it: if (!pm || !s) - DIE("panic: do_subst"); + DIE(aTHX_ "panic: do_subst"); strend = s + len; - maxiters = (strend - s) + 10; + maxiters = 2*(strend - s) + 10; /* We can match twice at each + position, once with zero-length, + second time with non-zero. */ - if (!rx->prelen && curpm) { - pm = curpm; + if (!rx->prelen && PL_curpm) { + pm = PL_curpm; rx = pm->op_pmregexp; } - screamer = ( (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) - ? TARG : Nullsv); - safebase = (!rx->nparens && !sawampersand) ? 0 : REXEC_COPY_STR; + r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) + ? REXEC_COPY_STR : 0; + if (SvSCREAM(TARG)) + r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { - SAVEINT(multiline); - multiline = pm->op_pmflags & PMf_MULTILINE; + SAVEINT(PL_multiline); + PL_multiline = pm->op_pmflags & PMf_MULTILINE; } orig = m = s; - if (rx->check_substr) { - if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */ - if (screamer) { - I32 p = -1; - - if (screamfirst[BmRARE(rx->check_substr)] < 0) - goto nope; - else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0))) - goto nope; - } - else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, - (unsigned char*)strend, - rx->check_substr))) - goto nope; - if (s && rx->check_offset_max < s - m) { - ++BmUSEFUL(rx->check_substr); - s -= rx->check_offset_max; - } - else - s = m; - } - /* Now checkstring is fixed, i.e. at fixed offset from the - beginning of match, and the match is anchored at s. */ - else if (!multiline) { /* Anchored at beginning of string. */ - I32 slen; - if (*SvPVX(rx->check_substr) != s[rx->check_offset_min] - || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), - s + rx->check_offset_min, slen))) - goto nope; - } - if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0 - && rx->check_substr == rx->float_substr) { - SvREFCNT_dec(rx->check_substr); - rx->check_substr = Nullsv; /* opt is being useless */ - rx->float_substr = Nullsv; - } + if (rx->reganch & RE_USE_INTUIT) { + s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + + if (!s) + goto nope; + /* How to do it in subst? */ +/* if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM)))) + goto yup; +*/ } /* only replace once? */ @@ -1547,11 +1798,13 @@ PP(pp_subst) c = dstr ? SvPV(dstr, clen) : Nullch; /* can do inplace substitution? */ - if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR)) + if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { - if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { SPAGAIN; - PUSHs(&sv_no); + PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); RETURN; } @@ -1561,17 +1814,12 @@ PP(pp_subst) goto force_it; } d = s; - curpm = pm; + PL_curpm = pm; SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { rxtainted |= RX_MATCH_TAINTED(rx); - if (rx->subbase) { - m = orig + (rx->startp[0] - rx->subbase); - d = orig + (rx->endp[0] - rx->subbase); - } else { - m = rx->startp[0]; - d = rx->endp[0]; - } + m = orig + rx->startp[0]; + d = orig + rx->endp[0]; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { @@ -1587,7 +1835,7 @@ PP(pp_subst) SvCUR_set(TARG, m - s); } /*SUPPRESS 560*/ - else if (i = m - s) { /* faster from front */ + else if ((i = m - s)) { /* faster from front */ d -= clen; m = d; sv_chop(TARG, d-i); @@ -1607,16 +1855,16 @@ PP(pp_subst) } TAINT_IF(rxtainted & 1); SPAGAIN; - PUSHs(&sv_yes); + PUSHs(&PL_sv_yes); } else { do { if (iters++ > maxiters) - DIE("Substitution loop"); + DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - m = rx->startp[0]; + m = rx->startp[0] + orig; /*SUPPRESS 560*/ - if (i = m - s) { + if ((i = m - s)) { if (s != d) Move(s, d, i, char); d += i; @@ -1625,9 +1873,11 @@ PP(pp_subst) Copy(c, d, clen, char); d += clen; } - s = rx->endp[0]; - } while (regexec_flags(rx, s, strend, orig, s == m, - Nullsv, NULL, 0)); /* don't match same null twice */ + s = rx->endp[0] + orig; + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + TARG, NULL, + /* don't match same null twice */ + REXEC_NOT_FIRST|REXEC_IGNOREPOS)); if (s != d) { i = strend - s; SvCUR_set(TARG, d - SvPVX(TARG) + i); @@ -1637,7 +1887,7 @@ PP(pp_subst) SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); TAINT_IF(rxtainted); if (SvSMAGICAL(TARG)) { PUTBACK; @@ -1649,7 +1899,9 @@ PP(pp_subst) RETURN; } - if (regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -1658,32 +1910,33 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); - curpm = pm; + PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; SPAGAIN; PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; do { if (iters++ > maxiters) - DIE("Substitution loop"); + DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - if (rx->subbase && rx->subbase != orig) { + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - orig = rx->subbase; + orig = rx->subbeg; s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0]; + m = rx->startp[0] + orig; sv_catpvn(dstr, s, m-s); - s = rx->endp[0]; + s = rx->endp[0] + orig; if (clen) sv_catpvn(dstr, c, clen); if (once) break; - } while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase)); + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); @@ -1708,11 +1961,9 @@ PP(pp_subst) goto ret_no; nope: - ++BmUSEFUL(rx->check_substr); - ret_no: SPAGAIN; - PUSHs(&sv_no); + PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); RETURN; } @@ -1722,20 +1973,20 @@ PP(pp_grepwhile) djSP; if (SvTRUEx(POPs)) - stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr]; - ++*markstack_ptr; + PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; + ++*PL_markstack_ptr; LEAVE; /* exit inner scope */ /* All done yet? */ - if (stack_base + *markstack_ptr > SP) { + if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; I32 gimme = GIMME_V; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ - items = --*markstack_ptr - markstack_ptr[-1]; + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; (void)POPMARK; /* pop dst */ - SP = stack_base + POPMARK; /* pop original mark */ + SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { dTARGET; XPUSHi(items); @@ -1748,9 +1999,9 @@ PP(pp_grepwhile) SV *src; ENTER; /* enter inner scope */ - SAVESPTR(curpm); + SAVEVPTR(PL_curpm); - src = stack_base[*markstack_ptr]; + src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); DEFSV = src; @@ -1766,19 +2017,33 @@ 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) - *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); + 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 { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ + FREETMPS; + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); + } + } + else + *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); + } else { MEXTEND(MARK, 0); - *MARK = &sv_undef; + *MARK = &PL_sv_undef; } SP = MARK; } @@ -1792,18 +2057,173 @@ PP(pp_leavesub) } PUTBACK; - POPSUB2(); /* Stack values are safe: release CV and @_ ... */ - curpm = newpm; /* ... and pop $1 et al */ + 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 { + /* 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 { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ + FREETMPS; + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); + } + } + 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 * -get_db_sub(SV **svp, CV *cv) + +STATIC CV * +S_get_db_sub(pTHX_ SV **svp, CV *cv) { dTHR; - SV *dbsv = GvSV(DBsub); + SV *dbsv = GvSV(PL_DBsub); if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); @@ -1816,22 +2236,24 @@ get_db_sub(SV **svp, CV *cv) && (gv = (GV*)*svp) ))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(dbsv, newRV((SV*)cv)); + SV *tmp = newRV((SV*)cv); + sv_setsv(dbsv, tmp); + SvREFCNT_dec(tmp); } else { gv_efullname3(dbsv, gv, Nullch); } } else { - SvUPGRADE(dbsv, SVt_PVIV); - SvIOK_on(dbsv); + (void)SvUPGRADE(dbsv, SVt_PVIV); + (void)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)) - curcopdb = curcop; - cv = GvCV(DBsub); + PL_curcopdb = PL_curcop; + cv = GvCV(PL_DBsub); return cv; } @@ -1843,18 +2265,19 @@ PP(pp_entersub) register CV *cv; register PERL_CONTEXT *cx; I32 gimme; - bool hasargs = (op->op_flags & OPf_STACKED) != 0; + bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; if (!sv) - DIE("Not a CODE reference"); + DIE(aTHX_ "Not a CODE reference"); switch (SvTYPE(sv)) { default: if (!SvROK(sv)) { char *sym; + STRLEN n_a; - if (sv == &sv_yes) { /* unfound import, ignore */ + if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) - SP = stack_base + POPMARK; + SP = PL_stack_base + POPMARK; RETURN; } if (SvGMAGICAL(sv)) { @@ -1862,27 +2285,36 @@ PP(pp_entersub) sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else - sym = SvPV(sv, na); + sym = SvPV(sv, n_a); if (!sym) - DIE(no_usym, "a subroutine"); - if (op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a subroutine"); - cv = perl_get_cv(sym, TRUE); + DIE(aTHX_ PL_no_usym, "a subroutine"); + if (PL_op->op_private & HINT_STRICT_REFS) + DIE(aTHX_ PL_no_symref, sym, "a subroutine"); + cv = get_cv(sym, TRUE); break; } + { + SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + tryAMAGICunDEREF(to_cv); + } cv = (CV*)SvRV(sv); if (SvTYPE(cv) == SVt_PVCV) break; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: - DIE("Not a CODE reference"); + DIE(aTHX_ "Not a CODE reference"); case SVt_PVCV: cv = (CV*)sv; break; case SVt_PVGV: if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, TRUE); + cv = sv_2cv(sv, &stash, &gv, FALSE); + if (!cv) { + ENTER; + SAVETMPS; + goto try_autoload; + } break; } @@ -1890,39 +2322,44 @@ PP(pp_entersub) SAVETMPS; retry: - if (!cv) - DIE("Not a CODE reference"); - if (!CvROOT(cv) && !CvXSUB(cv)) { GV* autogv; SV* sub_name; /* anonymous or undef'd function leaves us no recourse */ if (CvANON(cv) || !(gv = CvGV(cv))) - DIE("Undefined subroutine called"); + DIE(aTHX_ "Undefined subroutine called"); + /* autoloaded stub? */ if (cv != GvCV(gv)) { cv = GvCV(gv); - goto retry; } /* should call AUTOLOAD now? */ - if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + else { +try_autoload: + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) - { - cv = GvCV(autogv); - goto retry; + { + cv = GvCV(autogv); + } + /* sorry */ + else { + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, Nullch); + DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name)); + } } - /* sorry */ - sub_name = sv_newmortal(); - gv_efullname3(sub_name, gv, Nullch); - DIE("Undefined subroutine &%s called", SvPVX(sub_name)); + if (!cv) + DIE(aTHX_ "Not a CODE reference"); + goto retry; } gimme = GIMME_V; - if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) + if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { cv = get_db_sub(&sv, cv); - if (!cv) - DIE("No DBsub routine"); + if (!cv) + DIE(aTHX_ "No DBsub routine"); + } #ifdef USE_THREADS /* @@ -1934,16 +2371,18 @@ PP(pp_entersub) */ MUTEX_LOCK(CvMUTEXP(cv)); if (CvFLAGS(cv) & CVf_LOCKED) { - MAGIC *mg; - if (CvFLAGS(cv) & CVf_PACKAGE) { - sv = (SV *) CvGV(cv); - } - else if (CvFLAGS(cv) & CVf_METHOD) { - if (SP > stack_base + TOPMARK) - sv = *(stack_base + TOPMARK + 1); + MAGIC *mg; + if (CvFLAGS(cv) & CVf_METHOD) { + if (SP > PL_stack_base + TOPMARK) + sv = *(PL_stack_base + TOPMARK + 1); else { - MUTEX_UNLOCK(CvMUTEXP(cv)); - croak("no argument for locked method call"); + AV *av = (AV*)PL_curpad[0]; + if (hasargs || !av || AvFILLp(av) < 0 + || !(sv = AvARRAY(av)[0])) + { + MUTEX_UNLOCK(CvMUTEXP(cv)); + DIE(aTHX_ "no argument for locked method call"); + } } if (SvROK(sv)) sv = SvRV(sv); @@ -1965,11 +2404,10 @@ PP(pp_entersub) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_L(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)); - SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */ - save_destructor(unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); } @@ -2003,19 +2441,18 @@ PP(pp_entersub) * (3) instead of (2) so we'd have to clone. Would the fact * that we released the mutex more quickly make up for this? */ - if (threadnum && - (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) + if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) { /* We already have a clone to use */ MUTEX_UNLOCK(CvMUTEXP(cv)); cv = *(CV**)svp; - DEBUG_L(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 */ @@ -2023,16 +2460,17 @@ PP(pp_entersub) CvOWNER(cv) = thr; SvREFCNT_inc(cv); MUTEX_UNLOCK(CvMUTEXP(cv)); - DEBUG_L(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_L((PerlIO_printf(PerlIO_stderr(), + DEBUG_S((PerlIO_printf(Perl_debug_log, "entersub: %p cloning %p:%s\n", thr, cv, SvPEEK((SV*)cv)))); /* @@ -2049,17 +2487,18 @@ PP(pp_entersub) cv = clonecv; SvREFCNT_inc(cv); } - DEBUG_L(if (CvDEPTH(cv) != 0) - PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n", + DEBUG_S(if (CvDEPTH(cv) != 0) + 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 */ if (CvXSUB(cv)) { +#ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { - I32 (*fp3)_((int,int,int)); + I32 (*fp3)(int,int,int); dMARK; register I32 items = SP - MARK; /* We dont worry to copy from @_. */ @@ -2067,14 +2506,16 @@ PP(pp_entersub) SP[1] = SP[0]; SP--; } - stack_sp = mark + 1; - fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); + PL_stack_sp = mark + 1; + fp3 = (I32(*)(int,int,int))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, - MARK - stack_base + 1, + MARK - PL_stack_base + 1, items); - stack_sp = stack_base + items; + PL_stack_sp = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { I32 markix = TOPMARK; PUTBACK; @@ -2086,9 +2527,9 @@ PP(pp_entersub) AV* av; I32 items; #ifdef USE_THREADS - av = (AV*)curpad[0]; + av = (AV*)PL_curpad[0]; #else - av = GvAV(defgv); + av = GvAV(PL_defgv); #endif /* USE_THREADS */ items = AvFILLp(av) + 1; /* @_ is not tieable */ @@ -2100,23 +2541,22 @@ PP(pp_entersub) PUTBACK ; } } - if (curcopdb) { /* We assume that the first - XSUB in &DB::sub is the - called one. */ - SAVESPTR(curcop); - curcop = curcopdb; - curcopdb = NULL; + /* We assume first XSUB in &DB::sub is the called one. */ + if (PL_curcopdb) { + SAVEVPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(cv); + (void)(*CvXSUB(cv))(aTHXo_ cv); /* Enforce some sanity in scalar context. */ - if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) { - if (markix > stack_sp - stack_base) - *(stack_base + markix) = &sv_undef; + if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { + if (markix > PL_stack_sp - PL_stack_base) + *(PL_stack_base + markix) = &PL_sv_undef; else - *(stack_base + markix) = *stack_sp; - stack_sp = stack_base + markix; + *(PL_stack_base + markix) = *PL_stack_sp; + PL_stack_sp = PL_stack_base + markix; } } LEAVE; @@ -2127,24 +2567,28 @@ PP(pp_entersub) register I32 items = SP - MARK; AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); - push_return(op->op_next); + push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); CvDEPTH(cv)++; + /* XXX This would be a natural place to set C so + * that eval'' ops within this sub know the correct lexical space. + * Owing the speed considerations, we choose to search for the cv + * in doeval() instead. + */ if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn - && !(PERLDB_SUB && cv == GvCV(DBsub))) - sub_crush_depth(cv); + 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] != &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? */ @@ -2161,6 +2605,9 @@ PP(pp_entersub) 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); @@ -2177,7 +2624,7 @@ PP(pp_entersub) } #ifdef USE_THREADS if (!hasargs) { - AV* av = (AV*)curpad[0]; + AV* av = (AV*)PL_curpad[0]; items = AvFILLp(av) + 1; if (items) { @@ -2189,8 +2636,8 @@ PP(pp_entersub) } } #endif /* USE_THREADS */ - SAVESPTR(curpad); - curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); + SAVEVPTR(PL_curpad); + PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); #ifndef USE_THREADS if (hasargs) #endif /* USE_THREADS */ @@ -2199,18 +2646,22 @@ PP(pp_entersub) SV** ary; #if 0 - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p entersub preparing @_\n", thr)); #endif - av = (AV*)curpad[0]; + 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(defgv); - GvAV(defgv) = (AV*)SvREFCNT_inc(av); + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++MARK; @@ -2236,8 +2687,15 @@ PP(pp_entersub) MARK++; } } + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) + && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) + sub_crush_depth(cv); #if 0 - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p entersub returning %p\n", thr, CvSTART(cv))); #endif RETURNOP(CvSTART(cv)); @@ -2245,14 +2703,15 @@ PP(pp_entersub) } void -sub_crush_depth(CV *cv) +Perl_sub_crush_depth(pTHX_ CV *cv) { if (CvANON(cv)) - warn("Deep recursion on anonymous subroutine"); + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", + SvPVX(tmpstr)); } } @@ -2262,19 +2721,20 @@ PP(pp_aelem) SV** svp; I32 elem = POPi; AV* av = (AV*)POPs; - U32 lval = op->op_flags & OPf_MOD; - U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + U32 lval = PL_op->op_flags & OPf_MOD; + U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + SV *sv; if (elem > 0) - elem -= curcop->cop_arybase; + elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; svp = av_fetch(av, elem, lval && !defer); if (lval) { - if (!svp || *svp == &sv_undef) { + if (!svp || *svp == &PL_sv_undef) { SV* lv; if (!defer) - DIE(no_aelem, elem); + DIE(aTHX_ PL_no_aelem, elem); lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; @@ -2285,23 +2745,26 @@ PP(pp_aelem) PUSHs(lv); RETURN; } - if (op->op_private & OPpLVAL_INTRO) + if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); - else if (op->op_private & OPpDEREF) - vivify_ref(*svp, op->op_private & OPpDEREF); + else if (PL_op->op_private & OPpDEREF) + vivify_ref(*svp, PL_op->op_private & OPpDEREF); } - PUSHs(svp ? *svp : &sv_undef); + sv = (svp ? *svp : &PL_sv_undef); + if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ + sv = sv_mortalcopy(sv); + PUSHs(sv); RETURN; } void -vivify_ref(SV *sv, U32 to_what) +Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) { if (SvGMAGICAL(sv)) mg_get(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) - croak(no_modify); + Perl_croak(aTHX_ PL_no_modify); if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); else if (SvTYPE(sv) >= SVt_PV) { @@ -2328,25 +2791,45 @@ vivify_ref(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) +{ 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(meth, namelen); + sv = *(PL_stack_base + TOPMARK + 1); - name = SvPV(TOPs, na); - sv = *(stack_base + TOPMARK + 1); - if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) @@ -2360,25 +2843,50 @@ PP(pp_method) !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || !isIDFIRST(*packname)) - DIE("Can't call method \"%s\" without a package or object reference", name); + if (!packname || + ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) + ? !isIDFIRST_utf8((U8*)packname) + : !isIDFIRST(*packname) + )) + { + 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; } - *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } - if (!ob || !SvOBJECT(ob)) - DIE("Can't call method \"%s\" on unblessed reference", name); + if (!ob || !(SvOBJECT(ob) + || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) + && SvOBJECT(ob)))) + { + 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; char* sep = Nullch; char* p; + GV* gv; for (p = name; *p; p++) { if (*p == '\'') @@ -2387,17 +2895,47 @@ PP(pp_method) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = HvNAME(sep ? curcop->cop_stash : stash); + packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash); packlen = strlen(packname); } else { packname = name; packlen = sep - name; } - DIE("Can't locate object method \"%s\" via package \"%.*s\"", - leaf, (int)packlen, packname); + gv = gv_fetchpv(packname, 0, SVt_PVHV); + if (gv && isGV(gv)) { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"", + leaf, packname); + } + else { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%s\"" + " (perhaps you forgot to load \"%s\"?)", + leaf, packname, packname); + } } - SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); - RETURN; + return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } +#ifdef USE_THREADS +static void +unset_cvowner(pTHXo_ void *cvarg) +{ + register CV* cv = (CV *) cvarg; +#ifdef DEBUGGING + dTHR; +#endif /* DEBUGGING */ + + 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(Perl_debug_log, "depth %ld != 0\n", + CvDEPTH(cv));); + assert(thr == CvOWNER(cv)); + CvOWNER(cv) = 0; + MUTEX_UNLOCK(CvMUTEXP(cv)); + SvREFCNT_dec(cv); +} +#endif /* USE_THREADS */