X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=1b5f278e730675a3a8db98bf8dcb8e0cde1dbdc1;hb=7ed149c909e2812f62b12bd7d09f4ccfb79e0041;hp=f341d5839616277c087e740405d363781883e2ed;hpb=f6e565ef29539ecca34868149c9170b4470c45a2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index f341d58..1b5f278 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -145,38 +145,72 @@ PP(pp_concat) { dPOPTOPssrl; STRLEN len; - char *s; + U8 *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 */ + U8 *l, *c, *olds = NULL; + STRLEN targlen; + if (TARG == right) { + /* Need a safe copy elsewhere since we're just about to + write onto TARG */ + olds = (U8*)SvPV(right,len); + s = (U8*)savepv((char*)olds); + } + else + s = (U8*)SvPV(right,len); + l = (U8*)SvPV(left, targlen); + 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; 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); *s; 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) { - if (right_utf && !left_utf) - sv_utf8_upgrade(left); - s = SvPV(left,len); - SvUTF8_off(TARG); + s = (U8*)SvPV(left,len); 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); + 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)) { + else if (SvGMAGICAL(TARG)) mg_get(TARG); - if (right_utf && !left_utf) - sv_utf8_upgrade(left); - } - 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); - } - if (left_utf && !right_utf) - sv_utf8_upgrade(right); - s = SvPV(right,len); + s = (U8*)SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { @@ -190,11 +224,11 @@ PP(pp_concat) } } #endif - sv_catpvn(TARG,s,len); + sv_catpvn(TARG, (char *)s, len); } else - sv_setpvn(TARG,s,len); /* suppress warning */ - if (left_utf || right_utf) + sv_setpvn(TARG, (char *)s, len); /* suppress warning */ + if (left_utf) SvUTF8_on(TARG); SETTARG; RETURN; @@ -364,26 +398,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; @@ -1347,10 +1386,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) { @@ -1360,7 +1408,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); @@ -1887,7 +1935,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; @@ -2236,7 +2284,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);