X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=7d395141e89fa109a58826840309c1ad76c76349;hb=23f3aea032e3289acf8e6a178372c27e8e03f4a0;hp=66d22bcc75edc33716a1219147952ae9d49bb6c3;hpb=c2e66d9e68806a7000ee1a4760c35703a0e0ae89;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 66d22bc..7d39514 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -145,38 +145,73 @@ 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; + 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); + } + if (SvGMAGICAL(left)) + mg_get(left); + else if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) + sv_setpv(left, ""); /* Suppress warning. */ + 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 < 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) { - 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 +225,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; @@ -222,7 +257,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; @@ -237,7 +272,7 @@ PP(pp_readline) PP(pp_eq) { - djSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPnv; SETs(boolSV(TOPn == value)); @@ -275,7 +310,7 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPnnrl_ul; SETn( left + right ); @@ -342,8 +377,9 @@ PP(pp_print) else gv = PL_defoutgv; 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); @@ -364,26 +400,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; @@ -459,7 +502,7 @@ PP(pp_rv2av) } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -515,14 +558,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*); } @@ -563,7 +606,7 @@ PP(pp_rv2hv) } else { GV *gv; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -998,10 +1041,10 @@ PP(pp_match) 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; @@ -1011,7 +1054,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)) { @@ -1033,7 +1076,7 @@ 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))) @@ -1129,7 +1172,7 @@ yup: /* Confirmed by INTUIT */ rx->endp[0] = s - truebase + rx->minlen; rx->sublen = strend - truebase; goto gotcha; - } + } if (PL_sawampersand) { I32 off; @@ -1347,10 +1390,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 +1412,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); @@ -1496,15 +1548,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; @@ -1633,7 +1686,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 @@ -1659,7 +1712,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 @@ -1678,7 +1731,7 @@ PP(pp_iter) SvREFCNT_dec(*itersvp); if ((sv = SvMAGICAL(av) - ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) : AvARRAY(av)[++cx->blk_loop.iterix])) SvTEMP_off(sv); else @@ -1738,7 +1791,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)))) @@ -1759,7 +1814,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. */ @@ -1783,7 +1838,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)))) @@ -1961,7 +2016,7 @@ PP(pp_subst) goto ret_no; nope: -ret_no: +ret_no: SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -2020,7 +2075,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; @@ -2056,7 +2111,7 @@ PP(pp_leavesub) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2078,7 +2133,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { @@ -2209,7 +2264,7 @@ PP(pp_leavesublv) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2230,7 +2285,7 @@ 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) ))) { @@ -2508,7 +2563,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; @@ -2538,7 +2593,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. */ @@ -2632,7 +2687,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } #endif /* USE_THREADS */ @@ -2680,7 +2735,7 @@ try_autoload: } Copy(MARK,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + while (items--) { if (*MARK) SvTEMP_off(*MARK); @@ -2710,7 +2765,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)); } } @@ -2830,6 +2885,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)) @@ -2843,7 +2901,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)