X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=3f85116a31603439adf925248170de4de84966a7;hb=48f7ee7a00a9cc3c53df2208f08bd3848df9a5b5;hp=d2eef9b84ad22eac9119dcc93d078dc1ed00ce16;hpb=10c8fecdc2f0a2ef9c548abff5961fa25cd83eca;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index d2eef9b..3f85116 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -107,7 +107,6 @@ PP(pp_and) PP(pp_sassign) { djSP; dPOPTOPssrl; - MAGIC *mg; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -146,24 +145,83 @@ PP(pp_concat) { dPOPTOPssrl; STRLEN len; - char *s; + U8 *s; + bool left_utf; + bool right_utf; + + if (TARG == right && SvGMAGICAL(right)) + mg_get(right); + if (SvGMAGICAL(left)) + mg_get(left); + + left_utf = DO_UTF8(left); + right_utf = DO_UTF8(right); + + if (left_utf != right_utf) { + if (TARG == right && !right_utf) { + sv_utf8_upgrade(TARG); /* Now straight binary copy */ + SvUTF8_on(TARG); + } + else { + /* Set TARG to PV(left), then add right */ + U8 *l, *c, *olds = NULL; + STRLEN targlen; + s = (U8*)SvPV(right,len); + right_utf |= DO_UTF8(right); + if (TARG == right) { + /* Take a copy since we're about to overwrite TARG */ + olds = s = (U8*)savepvn((char*)s, len); + } + if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) { + if (SvREADONLY(left)) + left = sv_2mortal(newSVsv(left)); + else + sv_setpv(left, ""); /* Suppress warning. */ + } + l = (U8*)SvPV(left, targlen); + left_utf |= DO_UTF8(left); + if (TARG != left) + sv_setpvn(TARG, (char*)l, targlen); + if (!left_utf) + sv_utf8_upgrade(TARG); + /* Extend TARG to length of right (s) */ + targlen = SvCUR(TARG) + len; + if (!right_utf) { + /* plus one for each hi-byte char if we have to upgrade */ + for (c = s; c < s + len; c++) { + if (*c & 0x80) + targlen++; + } + } + SvGROW(TARG, targlen+1); + /* And now copy, maybe upgrading right to UTF8 on the fly */ + for (c = (U8*)SvEND(TARG); len--; s++) { + if (*s & 0x80 && !right_utf) + c = uv_to_utf8(c, *s); + else + *c++ = *s; + } + SvCUR_set(TARG, targlen); + *SvEND(TARG) = '\0'; + SvUTF8_on(TARG); + SETs(TARG); + Safefree(olds); + RETURN; + } + } if (TARG != left) { - s = SvPV(left,len); + s = (U8*)SvPV(left,len); if (TARG == right) { - sv_insert(TARG, 0, 0, s, len); + sv_insert(TARG, 0, 0, (char*)s, len); SETs(TARG); RETURN; } - sv_setpvn(TARG,s,len); + sv_setpvn(TARG, (char *)s, len); } - else if (SvGMAGICAL(TARG)) - mg_get(TARG); - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { + else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) sv_setpv(TARG, ""); /* Suppress warning. */ - s = SvPV_force(TARG, len); - } - s = SvPV(right,len); + s = (U8*)SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { @@ -177,19 +235,12 @@ PP(pp_concat) } } #endif - if (DO_UTF8(right)) - sv_utf8_upgrade(TARG); - sv_catpvn(TARG,s,len); - if (!IN_BYTE) { - if (SvUTF8(right)) - SvUTF8_on(TARG); - } - else if (!SvUTF8(right)) { - SvUTF8_off(TARG); - } + sv_catpvn(TARG, (char *)s, len); } else - sv_setpvn(TARG,s,len); /* suppress warning */ + sv_setpvn(TARG, (char *)s, len); /* suppress warning */ + if (left_utf) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -216,7 +267,7 @@ PP(pp_readline) 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) + 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; @@ -231,7 +282,7 @@ PP(pp_readline) PP(pp_eq) { - djSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPnv; SETs(boolSV(TOPn == value)); @@ -269,7 +320,7 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPnnrl_ul; SETn( left + right ); @@ -335,9 +386,10 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if (mg = SvTIED_mg((SV*)gv, 'q')) { + if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + had_magic: if (MARK == ORIGMARK) { - /* If using default handle then we need to make space to + /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... */ MEXTEND(SP, 1); @@ -358,26 +410,33 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if (ckWARN(WARN_UNOPENED)) { - SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", - SvPV(sv,n_a)); - } + dTHR; + if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q'))) + goto had_magic; + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { 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)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(gv)) { + SV* sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for input", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for input"); } - else if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "print", "filehandle"); + else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) + report_evil_fh(gv, io, PL_op->op_type); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; @@ -453,10 +512,10 @@ PP(pp_rv2av) } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -475,13 +534,17 @@ PP(pp_rv2av) } RETSETUNDEF; } - sym = SvPV(sv,n_a); + 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) + 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) @@ -505,14 +568,14 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; (void)POPs; /* XXXX May be optimized away? */ - EXTEND(SP, maxarg); + EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { - U32 i; + U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } - } + } else { Copy(AvARRAY(av), SP+1, maxarg, SV*); } @@ -553,10 +616,10 @@ PP(pp_rv2hv) } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -575,13 +638,17 @@ PP(pp_rv2hv) } RETSETUNDEF; } - sym = SvPV(sv,n_a); + 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) + 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) @@ -626,7 +693,6 @@ S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, SV **lastrelem) { OP *leftop; - SV *tmpstr; I32 i; leftop = ((BINOP*)PL_op)->op_last; @@ -655,7 +721,7 @@ S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, sv_setsv(tmpstr,relem[1]); /* value */ relem[1] = tmpstr; if (avhv_store_ent(ary,relem[0],tmpstr,0)) - SvREFCNT_inc(tmpstr); + (void)SvREFCNT_inc(tmpstr); if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) mg_set(tmpstr); relem += 2; @@ -689,7 +755,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) /* pseudohash */ tmpstr = sv_newmortal(); if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) - SvREFCNT_inc(tmpstr); + (void)SvREFCNT_inc(tmpstr); if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) mg_set(tmpstr); } @@ -737,7 +803,7 @@ PP(pp_aassign) EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { /*SUPPRESS 560*/ - if (sv = *relem) { + if ((sv = *relem)) { TAINT_NOT; /* Each item is independent */ *relem = sv_mortalcopy(sv); } @@ -979,16 +1045,16 @@ PP(pp_match) truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ - if (global = pm->op_pmflags & PMf_GLOBAL) { + 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) { if (!(rx->reganch & ROPT_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = mg->mg_len; + 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; + rx->endp[0] = rx->startp[0] = mg->mg_len; } minmatch = (mg->mg_flags & MGf_MINMATCH); update_minmatch = 0; @@ -998,7 +1064,7 @@ PP(pp_match) if ((gimme != G_ARRAY && !global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; - if (SvSCREAM(TARG)) + if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { @@ -1020,10 +1086,11 @@ play_it_again: if (!s) goto nope; if ( (rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand + && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) - && (r_flags & REXEC_SCREAM)))) + && (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)) @@ -1059,6 +1126,10 @@ play_it_again: 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) { @@ -1111,7 +1182,7 @@ yup: /* Confirmed by INTUIT */ rx->endp[0] = s - truebase + rx->minlen; rx->sublen = strend - truebase; goto gotcha; - } + } if (PL_sawampersand) { I32 off; @@ -1157,7 +1228,7 @@ Perl_do_readline(pTHX) I32 gimme = GIMME_V; MAGIC *mg; - if (mg = SvTIED_mg((SV*)PL_last_in_gv, 'q')) { + if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; @@ -1272,7 +1343,7 @@ Perl_do_readline(pTHX) } else { PerlIO_rewind(tmpfp); - IoTYPE(io) = '<'; + IoTYPE(io) = IoTYPE_RDONLY; IoIFP(io) = fp = tmpfp; IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ } @@ -1326,23 +1397,33 @@ 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() + && (IoTYPE(io) == IoTYPE_WRONLY || 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)); + /* integrate with report_evil_fh()? */ + char *name = NULL; + if (isGV(PL_last_in_gv)) { /* can this ever fail? */ + SV* sv = sv_newmortal(); + gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE); + name = SvPV_nolen(sv); + } + if (name && *name) + Perl_warner(aTHX_ WARN_IO, + "Filehandle %s opened only for output", name); + else + Perl_warner(aTHX_ WARN_IO, + "Filehandle opened only for output"); } } if (!fp) { - if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) { + 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"); + report_evil_fh(PL_last_in_gv, io, PL_op->op_type); } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); @@ -1372,8 +1453,7 @@ Perl_do_readline(pTHX) /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ - || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \ - || ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { if (!sv_gets(sv, fp, offset) @@ -1406,6 +1486,7 @@ Perl_do_readline(pTHX) SvTAINTED_on(sv); } IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { @@ -1478,15 +1559,16 @@ PP(pp_helem) U32 lval = PL_op->op_flags & OPf_MOD; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; + U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; if (SvTYPE(hv) == SVt_PVHV) { - he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + he = hv_fetch_ent(hv, keysv, lval && !defer, hash); 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); + svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash); } else { RETPUSHUNDEF; @@ -1615,7 +1697,7 @@ PP(pp_iter) /* safe to reuse old SV */ sv_setsv(*itersvp, cur); } - else + else #endif { /* we need a fresh SV every time so that loop body sees a @@ -1641,7 +1723,7 @@ PP(pp_iter) /* safe to reuse old SV */ sv_setiv(*itersvp, cx->blk_loop.iterix++); } - else + else #endif { /* we need a fresh SV every time so that loop body sees a @@ -1659,9 +1741,9 @@ PP(pp_iter) 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 = &PL_sv_undef; @@ -1712,7 +1794,6 @@ PP(pp_subst) STRLEN len; int force_on_match = 0; I32 oldsave = PL_savestack_ix; - I32 update_minmatch = 1; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; @@ -1721,7 +1802,9 @@ PP(pp_subst) else { TARG = DEFSV; EXTEND(SP,1); - } + } + if (SvFAKE(TARG) && SvREADONLY(TARG)) + sv_force_normal(TARG); if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) @@ -1742,7 +1825,7 @@ PP(pp_subst) DIE(aTHX_ "panic: do_subst"); strend = s + len; - maxiters = 2*(strend - s) + 10; /* We can match twice at each + maxiters = 2*(strend - s) + 10; /* We can match twice at each position, once with zero-length, second time with non-zero. */ @@ -1766,7 +1849,7 @@ PP(pp_subst) goto nope; /* How to do it in subst? */ /* if ( (rx->reganch & ROPT_CHECK_ALL) - && !PL_sawampersand + && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) @@ -1818,7 +1901,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); @@ -1847,7 +1930,7 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); 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; @@ -1870,7 +1953,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; @@ -1944,7 +2027,7 @@ PP(pp_subst) goto ret_no; nope: -ret_no: +ret_no: SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -2003,7 +2086,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; @@ -2015,8 +2098,10 @@ PP(pp_leavesub) sv_2mortal(*MARK); } else { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; - *MARK = sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } } else @@ -2037,7 +2122,7 @@ PP(pp_leavesub) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2059,7 +2144,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { @@ -2145,7 +2230,6 @@ PP(pp_leavesublv) : "an uninitialized value"); } else { - mortalize: /* Can be a localized value subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; (void)SvREFCNT_inc(*mark); @@ -2165,8 +2249,10 @@ PP(pp_leavesublv) sv_2mortal(*MARK); } else { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; - *MARK = sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } } else @@ -2189,7 +2275,7 @@ PP(pp_leavesublv) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2210,21 +2296,23 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) save_item(dbsv); if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") + || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == 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) = PTR2IV(cv); /* Do it the quickest way */ } @@ -2486,7 +2574,7 @@ try_autoload: } PL_stack_sp = mark + 1; fp3 = (I32(*)(int,int,int))CvXSUB(cv); - items = (*fp3)(CvXSUBANY(cv).any_i32, + items = (*fp3)(CvXSUBANY(cv).any_i32, MARK - PL_stack_base + 1, items); PL_stack_sp = PL_stack_base + items; @@ -2516,7 +2604,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } /* We assume first XSUB in &DB::sub is the called one. */ @@ -2610,7 +2698,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } #endif /* USE_THREADS */ @@ -2639,6 +2727,7 @@ try_autoload: 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; @@ -2657,7 +2746,7 @@ try_autoload: } Copy(MARK,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + while (items--) { if (*MARK) SvTEMP_off(*MARK); @@ -2687,7 +2776,7 @@ Perl_sub_crush_depth(pTHX_ CV *cv) else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", + Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } @@ -2696,7 +2785,7 @@ PP(pp_aelem) { djSP; SV** svp; - I32 elem = POPi; + IV elem = POPi; AV* av = (AV*)POPs; U32 lval = PL_op->op_flags & OPf_MOD; U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); @@ -2795,7 +2884,6 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - djSP; SV* sv; SV* ob; GV* gv; @@ -2808,6 +2896,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) name = SvPV(meth, namelen); sv = *(PL_stack_base + TOPMARK + 1); + if (!sv) + Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); + if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) @@ -2821,7 +2912,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || + if (!packname || ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) @@ -2864,6 +2955,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) char* leaf = name; char* sep = Nullch; char* p; + GV* gv; for (p = name; *p; p++) { if (*p == '\'') @@ -2879,9 +2971,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp) packname = name; packlen = sep - name; } - Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"", - leaf, 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); + } } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; }