X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=6df5420db7f5fbffb0bc39432488cd668bc920f5;hb=0df67ae6657908368da0106eaece7afb31cc07d7;hp=5db5eab6f78ee029895f65c2819158be49a9eb6e;hpb=92d29cee5ff815b05b81b877528e4c77e73881c9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 5db5eab..6df5420 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -146,6 +146,53 @@ PP(pp_concat) dPOPTOPssrl; STRLEN len; char *s; + bool left_utf = DO_UTF8(left); + bool 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 */ + char *l, *c; + STRLEN targlen; + if (TARG == right) + /* Need a safe copy elsewhere since we're just about to + write onto TARG */ + s = strdup(SvPV(right,len)); + else + s = SvPV(right,len); + l = SvPV(left, targlen); + if (TARG != left) + sv_setpvn(TARG,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; c++) { + if (*c & 0x80) + targlen++; + } + } + SvGROW(TARG, targlen+1); + /* And now copy, maybe upgrading right to UTF8 on the fly */ + for (c = SvEND(TARG); *s; s++) { + if (*s & 0x80 && !right_utf) + c = (char*)uv_to_utf8((U8*)c, *s); + else + *c++ = *s; + } + SvCUR_set(TARG, targlen); + *SvEND(TARG) = '\0'; + SvUTF8_on(TARG); + SETs(TARG); + RETURN; + } + } if (TARG != left) { s = SvPV(left,len); @@ -158,10 +205,8 @@ PP(pp_concat) } 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); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) @@ -176,19 +221,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); - } } else sv_setpvn(TARG,s,len); /* suppress warning */ + if (left_utf) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -455,7 +493,7 @@ PP(pp_rv2av) if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -474,13 +512,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) @@ -555,7 +597,7 @@ PP(pp_rv2hv) if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -574,13 +616,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) @@ -1375,8 +1421,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) @@ -1409,6 +1454,7 @@ Perl_do_readline(pTHX) SvTAINTED_on(sv); } IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { @@ -1872,7 +1918,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; @@ -2221,7 +2267,9 @@ S_get_db_sub(pTHX_ 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); @@ -2644,6 +2692,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; @@ -2868,6 +2917,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 == '\'') @@ -2883,9 +2933,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; }