X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=f2e8e211cb9c1f9b8cccac8381f56519824ef23b;hb=11faa288e292c27cb2ddc4ccdc483b523d26ce19;hp=d3a1f5c7da5c2d840b74981148690f97cebf7ce5;hpb=1cab015a482fdf2a2c78aa5bae65199be3b5e3c8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index d3a1f5c..f2e8e21 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -34,25 +34,7 @@ /* Hot code. */ #ifdef USE_THREADS -STATIC void -S_unset_cvowner(pTHX_ void *cvarg) -{ - register CV* cv = (CV *) cvarg; -#ifdef DEBUGGING - dTHR; -#endif /* DEBUGGING */ - - DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%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", - 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) @@ -76,9 +58,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)); else - PUSHs(GvSV(cGVOP->op_gv)); + PUSHs(GvSV(cGVOP)); RETURN; } @@ -87,6 +69,12 @@ PP(pp_null) return NORMAL; } +PP(pp_setstate) +{ + PL_curcop = (COP*)PL_op; + return NORMAL; +} + PP(pp_pushmark) { PUSHMARK(PL_stack_sp); @@ -107,7 +95,7 @@ PP(pp_stringify) PP(pp_gv) { djSP; - XPUSHs((SV*)cGVOP->op_gv); + XPUSHs((SV*)cGVOP); RETURN; } @@ -142,9 +130,9 @@ 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) @@ -176,8 +164,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; @@ -233,7 +234,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) { @@ -270,7 +271,7 @@ PP(pp_add) PP(pp_aelemfast) { djSP; - AV *av = GvAV((GV*)cSVOP->op_sv); + AV *av = GvAV(cGVOP); 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); @@ -350,23 +351,24 @@ PP(pp_print) if (!(io = GvIO(gv))) { if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a)); + 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 (ckWARN2(WARN_CLOSED, WARN_IO)) { SV* sv = sv_newmortal(); - gv_fullname3(sv, gv, Nullch); + gv_efullname3(sv, gv, Nullch); if (IoIFP(io)) - Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input", - SvPV(sv,n_a)); + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", + SvPV(sv,n_a)); else if (ckWARN(WARN_CLOSED)) - Perl_warner(aTHX_ WARN_CLOSED, "print on closed filehandle %s", - SvPV(sv,n_a)); + Perl_warner(aTHX_ WARN_CLOSED, + "print on closed filehandle %s", SvPV(sv,n_a)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -600,8 +602,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); @@ -772,8 +774,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 @@ -801,8 +803,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)); } @@ -846,10 +848,8 @@ PP(pp_match) register char *s; char *strend; I32 global; - I32 r_flags = 0; - char *truebase; /* Start of string, may be - relocated if REx engine - copies the string. */ + I32 r_flags = REXEC_CHECKED; + char *truebase; /* Start of string */ register REGEXP *rx = pm->op_pmregexp; bool rxtainted; I32 gimme = GIMME; @@ -909,9 +909,7 @@ PP(pp_match) if ((gimme != G_ARRAY && !global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; - if (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { @@ -927,76 +925,17 @@ play_it_again: if (update_minmatch++) minmatch = had_zerolen; } - if (rx->check_substr) { - if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */ - SV *c = rx->check_substr; - - if (r_flags & REXEC_SCREAM) { - I32 p = -1; - char *b; - - if (PL_screamfirst[BmRARE(c)] < 0 - && !( BmRARE(c) == '\n' && (BmPREVIOUS(c) == SvCUR(c) - 1) - && SvTAIL(c) )) - goto nope; - - b = (char*)HOP((U8*)s, rx->check_offset_min); - if (!(s = screaminstr(TARG, c, b - s, 0, &p, 0))) - goto nope; - - if ((rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand && !SvTAIL(c)) - goto yup; - } - else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), - (unsigned char*)strend, c, - PL_multiline ? FBMrf_MULTILINE : 0))) - goto nope; - else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand) - goto yup; - if (s && rx->check_offset_max < s - t) { - ++BmUSEFUL(c); - s = (char*)HOP((U8*)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 (!PL_multiline) { /* Anchored near beginning of string. */ - I32 slen; - char *b = (char*)HOP((U8*)s, rx->check_offset_min); - - if (SvTAIL(rx->check_substr)) { - slen = SvCUR(rx->check_substr); /* >= 1 */ - - if ( strend - b > slen || strend - b < slen - 1 ) - goto nope; - if ( strend - b == slen && strend[-1] != '\n') - goto nope; - /* Now should match b[0..slen-2] */ - slen--; - if (slen && (*SvPVX(rx->check_substr) != *b - || (slen > 1 - && memNE(SvPVX(rx->check_substr), b, slen)))) - goto nope; - if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand) - goto yup; - } else { /* Assume len > 0 */ - if (*SvPVX(rx->check_substr) != *b - || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), b, slen))) - goto nope; - if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand) - goto yup; - } - } - if (!(rx->reganch & ROPT_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; + if ( (rx->reganch & ROPT_CHECK_ALL) + && !PL_sawampersand + && ((rx->reganch & ROPT_NOSCAN) + || !((rx->reganch & RE_INTUIT_TAIL) + && (r_flags & REXEC_SCREAM)))) + goto yup; } if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { @@ -1066,11 +1005,10 @@ 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); PL_curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmdynflags |= PMdf_USED; @@ -1081,7 +1019,7 @@ yup: /* Confirmed by check_substr */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + SvCUR(rx->check_substr); + rx->endp[0] = s - truebase + rx->minlen; rx->sublen = strend - truebase; goto gotcha; } @@ -1092,19 +1030,16 @@ yup: /* Confirmed by check_substr */ rx->sublen = strend - t; RX_MATCH_COPIED_on(rx); off = rx->startp[0] = s - t; - rx->endp[0] = off + SvCUR(rx->check_substr); + rx->endp[0] = off + rx->minlen; } else { /* startp/endp are used by @- @+. */ rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + SvCUR(rx->check_substr); + rx->endp[0] = s - truebase + rx->minlen; } 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)) { @@ -1150,9 +1085,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)); @@ -1163,7 +1098,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) { @@ -1295,15 +1229,29 @@ Perl_do_readline(pTHX) } 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 (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { if (type == OP_GLOB) - Perl_warner(aTHX_ WARN_CLOSED, "glob failed (can't start child: %s)", - Strerror(errno)); - else - Perl_warner(aTHX_ WARN_CLOSED, "Read on closed filehandle <%s>", - GvENAME(PL_last_in_gv)); + Perl_warner(aTHX_ WARN_CLOSED, + "glob failed (can't start child: %s)", + Strerror(errno)); + else { + SV* sv = sv_newmortal(); + gv_efullname3(sv, PL_last_in_gv, Nullch); + Perl_warner(aTHX_ WARN_CLOSED, + "Read on closed filehandle %s", + SvPV_nolen(sv)); + } } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1347,7 +1295,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)) { @@ -1646,7 +1593,7 @@ 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; } @@ -1690,7 +1637,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); @@ -1717,56 +1664,26 @@ PP(pp_subst) } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) ? REXEC_COPY_STR : 0; - if (SvSCREAM(TARG) && rx->check_substr - && SvTYPE(rx->check_substr) == SVt_PVBM - && SvVALID(rx->check_substr)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { 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 (r_flags & REXEC_SCREAM) { - I32 p = -1; - char *b; - - if (PL_screamfirst[BmRARE(rx->check_substr)] < 0) - goto nope; - - b = (char*)HOP((U8*)s, rx->check_offset_min); - if (!(s = screaminstr(TARG, rx->check_substr, b - s, 0, &p, 0))) - goto nope; - } - else if (!(s = fbm_instr((unsigned char*)HOP((U8*)s, rx->check_offset_min), - (unsigned char*)strend, - rx->check_substr, - PL_multiline ? FBMrf_MULTILINE : 0))) - goto nope; - if (s && rx->check_offset_max < s - m) { - ++BmUSEFUL(rx->check_substr); - s = (char*)HOP((U8*)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 (!PL_multiline) { /* Anchored at beginning of string. */ - I32 slen; - char *b = (char*)HOP((U8*)s, rx->check_offset_min); - if (*SvPVX(rx->check_substr) != *b - || ((slen = SvCUR(rx->check_substr)) > 1 - && memNE(SvPVX(rx->check_substr), b, slen))) - goto nope; - } - if (!(rx->reganch & ROPT_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? */ @@ -1778,7 +1695,9 @@ PP(pp_subst) /* can do inplace substitution? */ if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { - if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) { + if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + r_flags | REXEC_CHECKED)) + { SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -1851,7 +1770,9 @@ PP(pp_subst) } s = rx->endp[0] + orig; } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, - Nullsv, NULL, REXEC_NOT_FIRST)); /* don't match same null twice */ + 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); @@ -1873,7 +1794,9 @@ PP(pp_subst) RETURN; } - if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) { + 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); @@ -1933,8 +1856,6 @@ PP(pp_subst) goto ret_no; nope: - ++BmUSEFUL(rx->check_substr); - ret_no: SPAGAIN; PUSHs(&PL_sv_no); @@ -1991,27 +1912,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; } @@ -2027,13 +1950,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) { @@ -2061,7 +2138,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)) @@ -2194,7 +2271,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)) @@ -2217,10 +2294,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)); - save_destructor(Perl_unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } MUTEX_LOCK(CvMUTEXP(cv)); } @@ -2259,13 +2336,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(S_unset_cvowner, (void*) cv); + SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } else { /* (2) => grab ownership of cv. (3) => make clone */ @@ -2273,16 +2350,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)))); /* @@ -2300,9 +2378,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(S_unset_cvowner, (void*) cv); + SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } } #endif /* USE_THREADS */ @@ -2415,6 +2493,9 @@ try_autoload: SvPADMY_on(sv); } } + else if (IS_PADGV(oldpad[ix])) { + av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix])); + } else { av_store(newpad, ix, sv = NEWSV(0,0)); SvPADTMP_on(sv); @@ -2453,13 +2534,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); @@ -2498,7 +2582,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)); @@ -2594,25 +2678,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)) @@ -2632,9 +2737,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; @@ -2643,11 +2748,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; @@ -2661,17 +2778,38 @@ 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 +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 */