X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=0a0c084144ec3fdf27bd8ba06a72da5c2ac5e21d;hb=93d6612c1a533e775e2884e98da42e418edd3a83;hp=8d35b7e4b11f60b549888f31982acfcccacc1a2c;hpb=80814d4c448093ff1bbffc8303aa2b382c1caa70;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 8d35b7e..0a0c084 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -156,31 +156,30 @@ PP(pp_concat) } else { /* Set TARG to PV(left), then add right */ - U8 *l, *c; + U8 *l, *c, *olds = NULL; 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); + s = (U8*)SvPV(right,len); + if (TARG == right) { + /* Take a copy since we're about to overwrite TARG */ + olds = s = (U8*)savepvn((char*)s, len); + } + l = (U8*)SvPV(left, targlen); if (TARG != left) - sv_setpvn(TARG,l,targlen); + 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; c++) { + 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 = SvEND(TARG); *s; s++) { + for (c = (U8*)SvEND(TARG); len--; s++) { if (*s & 0x80 && !right_utf) c = uv_to_utf8(c, *s); else @@ -190,24 +189,25 @@ PP(pp_concat) *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) sv_setpv(TARG, ""); /* Suppress warning. */ - s = SvPV(right,len); + s = (U8*)SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { @@ -221,10 +221,10 @@ PP(pp_concat) } } #endif - sv_catpvn(TARG,s,len); + 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; @@ -395,26 +395,31 @@ 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 (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; @@ -1378,10 +1383,19 @@ Perl_do_readline(pTHX) && (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)); + /* 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) { @@ -1391,7 +1405,7 @@ Perl_do_readline(pTHX) "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); @@ -2267,7 +2281,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); @@ -2915,6 +2931,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 == '\'') @@ -2930,9 +2947,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; }