X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/3818b22bb9ef820a2553aa5e3504220f3b156f21..83f7a2bcd26f7d7ec810b4a44e070007e09025e6:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 6ef302c..237bb01 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -22,13 +22,6 @@ #ifdef I_UNISTD #include #endif -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif - /* Hot code. */ @@ -87,6 +80,8 @@ PP(pp_stringify) char *s; s = SvPV(TOPs,len); sv_setpvn(TARG,s,len); + if (SvUTF8(TOPs) && !IN_BYTE) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -112,7 +107,6 @@ PP(pp_and) PP(pp_sassign) { djSP; dPOPTOPssrl; - MAGIC *mg; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -171,18 +165,27 @@ PP(pp_concat) s = SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) - if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_MISC)) { + if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) { STRLEN n; char *s = SvPV(TARG,n); if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' && (n == 2 || !isDIGIT(s[n-3]))) { - Perl_warner(aTHX_ WARN_MISC, "Possible Y2K bug: %s", + Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", "about to append an integer to '19'"); } } #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 */ @@ -331,7 +334,7 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if (mg = SvTIED_mg((SV*)gv, 'q')) { + if ((mg = SvTIED_mg((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... @@ -617,6 +620,92 @@ PP(pp_rv2hv) } } +STATIC int +S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, + SV **lastrelem) +{ + OP *leftop; + I32 i; + + leftop = ((BINOP*)PL_op)->op_last; + assert(leftop); + assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST); + leftop = ((LISTOP*)leftop)->op_first; + assert(leftop); + /* Skip PUSHMARK and each element already assigned to. */ + for (i = lelem - firstlelem; i > 0; i--) { + leftop = leftop->op_sibling; + assert(leftop); + } + if (leftop->op_type != OP_RV2HV) + return 0; + + /* pseudohash */ + if (av_len(ary) > 0) + av_fill(ary, 0); /* clear all but the fields hash */ + if (lastrelem >= relem) { + while (relem < lastrelem) { /* gobble up all the rest */ + SV *tmpstr; + assert(relem[0]); + assert(relem[1]); + /* Avoid a memory leak when avhv_store_ent dies. */ + tmpstr = sv_newmortal(); + sv_setsv(tmpstr,relem[1]); /* value */ + relem[1] = tmpstr; + if (avhv_store_ent(ary,relem[0],tmpstr,0)) + (void)SvREFCNT_inc(tmpstr); + if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + relem += 2; + TAINT_NOT; + } + } + if (relem == lastrelem) + return 1; + return 2; +} + +STATIC void +S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) +{ + if (*relem) { + SV *tmpstr; + if (ckWARN(WARN_MISC)) { + if (relem == firstrelem && + SvROK(*relem) && + (SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV)) + { + Perl_warner(aTHX_ WARN_MISC, + "Reference found where even-sized list expected"); + } + else + Perl_warner(aTHX_ WARN_MISC, + "Odd number of elements in hash assignment"); + } + if (SvTYPE(hash) == SVt_PVAV) { + /* pseudohash */ + tmpstr = sv_newmortal(); + if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) + (void)SvREFCNT_inc(tmpstr); + if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + } + else { + HE *didstore; + tmpstr = NEWSV(29,0); + didstore = hv_store_ent(hash,*relem,tmpstr,0); + if (SvMAGICAL(hash)) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + sv_2mortal(tmpstr); + } + } + TAINT_NOT; + } +} + PP(pp_aassign) { djSP; @@ -642,21 +731,22 @@ PP(pp_aassign) * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ - if (PL_op->op_private & OPpASSIGN_COMMON) { + if (PL_op->op_private & (OPpASSIGN_COMMON)) { EXTEND_MORTAL(lastrelem - firstrelem + 1); - for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ - if (sv = *relem) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if ((sv = *relem)) { TAINT_NOT; /* Each item is independent */ - *relem = sv_mortalcopy(sv); + *relem = sv_mortalcopy(sv); } - } + } } relem = firstrelem; lelem = firstlelem; ary = Null(AV*); hash = Null(HV*); + while (lelem <= lastlelem) { TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; @@ -664,7 +754,19 @@ PP(pp_aassign) case SVt_PVAV: ary = (AV*)sv; magic = SvMAGICAL(ary) != 0; - + if (PL_op->op_private & OPpASSIGN_HASH) { + switch (do_maybe_phash(ary, lelem, firstlelem, relem, + lastrelem)) + { + case 0: + goto normal_array; + case 1: + do_oddball((HV*)ary, relem, firstrelem); + } + relem = lastrelem + 1; + break; + } + normal_array: av_clear(ary); av_extend(ary, lastrelem - relem); i = 0; @@ -684,7 +786,7 @@ PP(pp_aassign) TAINT_NOT; } break; - case SVt_PVHV: { + case SVt_PVHV: { /* normal hash */ SV *tmpstr; hash = (HV*)sv; @@ -711,27 +813,7 @@ PP(pp_aassign) TAINT_NOT; } if (relem == lastrelem) { - if (*relem) { - HE *didstore; - if (ckWARN(WARN_UNSAFE)) { - if (relem == firstrelem && - SvROK(*relem) && - ( SvTYPE(SvRV(*relem)) == SVt_PVAV || - SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) - Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected"); - else - Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); - } - tmpstr = NEWSV(29,0); - didstore = hv_store_ent(hash,*relem,tmpstr,0); - if (magic) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - if (!didstore) - sv_2mortal(tmpstr); - } - TAINT_NOT; - } + do_oddball(hash, relem, firstrelem); relem++; } } @@ -895,7 +977,7 @@ 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'); @@ -1073,7 +1155,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; @@ -1252,9 +1334,9 @@ Perl_do_readline(pTHX) } } if (!fp) { - if (ckWARN(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_CLOSED, + Perl_warner(aTHX_ WARN_GLOB, "glob failed (can't start child: %s)", Strerror(errno)); else @@ -1303,8 +1385,8 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); } else if (type == OP_GLOB) { - if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) { - Perl_warner(aTHX_ WARN_CLOSED, + if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { + Perl_warner(aTHX_ WARN_GLOB, "glob failed (child exited with status %d%s)", (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); @@ -1575,9 +1657,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; @@ -1628,7 +1710,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; @@ -1734,7 +1815,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); @@ -1763,7 +1844,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; @@ -1931,8 +2012,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 @@ -2061,7 +2144,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); @@ -2081,8 +2163,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 @@ -2139,8 +2223,8 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) } } 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 */ } @@ -2711,7 +2795,6 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - djSP; SV* sv; SV* ob; GV* gv; @@ -2753,9 +2836,13 @@ S_method_common(pTHX_ SV* meth, U32* hashp) *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } - if (!ob || !SvOBJECT(ob)) + if (!ob || !(SvOBJECT(ob) + || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) + && SvOBJECT(ob)))) + { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", name); + } stash = SvSTASH(ob);