X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7e8961ecc77ac069ddd54d220ef48fd89f1122d6..118f16236d9a1880b589c5276b32966c476662d7:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index a8b9dff..208d89b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,7 @@ /* pp_hot.c * - * Copyright (c) 1991-2003, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -140,7 +141,7 @@ PP(pp_concat) if (TARG == right && right != left) { right = sv_2mortal(newSVpvn(rpv, rlen)); - rpv = SvPV(right, rlen); /* no point setting UTF8 here */ + rpv = SvPV(right, rlen); /* no point setting UTF-8 here */ rcopied = TRUE; } @@ -794,6 +795,7 @@ PP(pp_rv2hv) { dSP; dTOPss; HV *hv; + I32 gimme = GIMME_V; if (SvROK(sv)) { wasref: @@ -807,7 +809,7 @@ PP(pp_rv2hv) RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) + if (gimme != G_ARRAY) Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); SETs((SV*)hv); RETURN; @@ -824,7 +826,7 @@ PP(pp_rv2hv) RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) + if (gimme != G_ARRAY) Perl_croak(aTHX_ "Can't return hash to lvalue" " scalar context"); SETs((SV*)hv); @@ -849,7 +851,7 @@ PP(pp_rv2hv) DIE(aTHX_ PL_no_usym, "a HASH"); if (ckWARN(WARN_UNINITIALIZED)) report_uninit(); - if (GIMME == G_ARRAY) { + if (gimme == G_ARRAY) { SP--; RETURN; } @@ -884,7 +886,7 @@ PP(pp_rv2hv) RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) + if (gimme != G_ARRAY) Perl_croak(aTHX_ "Can't return hash to lvalue" " scalar context"); SETs((SV*)hv); @@ -893,21 +895,16 @@ PP(pp_rv2hv) } } - if (GIMME == G_ARRAY) { /* array wanted */ + if (gimme == G_ARRAY) { /* array wanted */ *PL_stack_sp = (SV*)hv; return do_kv(); } - else { + else if (gimme == G_SCALAR) { dTARGET; - if (HvFILL(hv)) - Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf, - (IV)HvFILL(hv), (IV)HvMAX(hv) + 1); - else - sv_setiv(TARG, 0); - + TARG = Perl_hv_scalar(aTHX_ hv); SETTARG; - RETURN; } + RETURN; } STATIC void @@ -961,8 +958,12 @@ PP(pp_aassign) HV *hash; I32 i; int magic; + int duplicates = 0; + SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */ + PL_delaymagic = DM_DELAY; /* catch simultaneous items */ + gimme = GIMME_V; /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't @@ -1016,6 +1017,7 @@ PP(pp_aassign) hash = (HV*)sv; magic = SvMAGICAL(hash) != 0; hv_clear(hash); + firsthashrelem = relem; while (relem < lastrelem) { /* gobble up all the rest */ HE *didstore; @@ -1027,6 +1029,9 @@ PP(pp_aassign) if (*relem) sv_setsv(tmpstr,*relem); /* value */ *(relem++) = tmpstr; + if (gimme != G_VOID && hv_exists_ent(hash, sv, 0)) + /* key overwrites an existing entry */ + duplicates += 2; didstore = hv_store_ent(hash,sv,tmpstr,0); if (magic) { if (SvSMAGICAL(tmpstr)) @@ -1061,10 +1066,13 @@ PP(pp_aassign) if (PL_delaymagic & ~DM_DELAY) { if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - (void)setresuid(PL_uid,PL_euid,(Uid_t)-1); + (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, + (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1, + (Uid_t)-1); #else # ifdef HAS_SETREUID - (void)setreuid(PL_uid,PL_euid); + (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, + (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1); # else # ifdef HAS_SETRUID if ((PL_delaymagic & DM_UID) == DM_RUID) { @@ -1074,7 +1082,7 @@ PP(pp_aassign) # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID if ((PL_delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(PL_uid); + (void)seteuid(PL_euid); PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ @@ -1090,10 +1098,13 @@ PP(pp_aassign) } if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - (void)setresgid(PL_gid,PL_egid,(Gid_t)-1); + (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, + (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1, + (Gid_t)-1); #else # ifdef HAS_SETREGID - (void)setregid(PL_gid,PL_egid); + (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, + (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1); # else # ifdef HAS_SETRGID if ((PL_delaymagic & DM_GID) == DM_RGID) { @@ -1103,7 +1114,7 @@ PP(pp_aassign) # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID if ((PL_delaymagic & DM_GID) == DM_EGID) { - (void)setegid(PL_gid); + (void)setegid(PL_egid); PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ @@ -1121,17 +1132,26 @@ PP(pp_aassign) } PL_delaymagic = 0; - gimme = GIMME_V; if (gimme == G_VOID) SP = firstrelem - 1; else if (gimme == G_SCALAR) { dTARGET; SP = firstrelem; - SETi(lastrelem - firstrelem + 1); + SETi(lastrelem - firstrelem + 1 - duplicates); } else { - if (ary || hash) + if (ary) + SP = lastrelem; + else if (hash) { + if (duplicates) { + /* Removes from the stack the entries which ended up as + * duplicated keys in the hash (fix for [perl #24380]) */ + Move(firsthashrelem + duplicates, + firsthashrelem, duplicates, SV**); + lastrelem -= duplicates; + } SP = lastrelem; + } else SP = firstrelem + (lastlelem - firstlelem); lelem = firstlelem + (relem - firstrelem); @@ -1233,7 +1253,7 @@ PP(pp_match) if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } @@ -1405,7 +1425,7 @@ yup: /* Confirmed by INTUIT */ rx->startp[0] = s - truebase; rx->endp[0] = s - truebase + rx->minlen; } - rx->nparens = rx->lastparen = 0; /* used by @- and @+ */ + rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ LEAVE_SCOPE(oldsave); RETPUSHYES; @@ -1496,7 +1516,7 @@ Perl_do_readline(pTHX) /* undef TARG, and push that undefined value */ if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + (void)SvOK_off(TARG); } PUSHTARG; } @@ -1540,7 +1560,9 @@ Perl_do_readline(pTHX) for (;;) { PUTBACK; if (!sv_gets(sv, fp, offset) - && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) + && (type == OP_GLOB + || SNARF_EOF(gimme, PL_rs, io, sv) + || PerlIO_error(fp))) { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { @@ -1560,7 +1582,7 @@ Perl_do_readline(pTHX) if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); + (void)SvOK_off(TARG); } SPAGAIN; PUSHTARG; @@ -1592,6 +1614,17 @@ Perl_do_readline(pTHX) (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } + } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + U8 *s = (U8*)SvPVX(sv) + offset; + STRLEN len = SvCUR(sv) - offset; + U8 *f; + + if (ckWARN(WARN_UTF8) && + !Perl_is_utf8_string_loc(aTHX_ s, len, &f)) + /* Emulate :encoding(utf8) warning in the same case. */ + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "utf8 \"\\x%02X\" does not map to Unicode", + f < (U8*)SvEND(sv) ? *f : 0); } if (gimme == G_ARRAY) { if (SvLEN(sv) - SvCUR(sv) > 20) { @@ -1858,6 +1891,11 @@ PP(pp_iter) else { sv = AvARRAY(av)[++cx->blk_loop.iterix]; } + if (sv && SvREFCNT(sv) == 0) { + *itersvp = Nullsv; + Perl_croak(aTHX_ "Use of freed value in iteration"); + } + if (sv) SvTEMP_off(sv); else @@ -1972,7 +2010,7 @@ PP(pp_subst) ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { + if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } @@ -2154,6 +2192,7 @@ PP(pp_subst) if (!c) { register PERL_CONTEXT *cx; SPAGAIN; + ReREFCNT_inc(rx); PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } @@ -2283,6 +2322,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ TAINT_NOT; if (gimme == G_SCALAR) { @@ -2321,6 +2361,7 @@ PP(pp_leavesub) PUTBACK; LEAVE; + cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2341,6 +2382,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ TAINT_NOT; @@ -2377,6 +2419,7 @@ PP(pp_leavesublv) * TEMP, so sv_2mortal is out of question. */ if (!CvLVALUE(cx->blk_sub.cv)) { LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2388,6 +2431,7 @@ PP(pp_leavesublv) if (MARK == SP) { if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2403,6 +2447,7 @@ PP(pp_leavesublv) } else { /* Should not happen? */ LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2419,6 +2464,7 @@ PP(pp_leavesublv) /* Might be flattened array after $#array = */ PUTBACK; LEAVE; + cxstack_ix--; POPSUB(cx,sv); PL_curpm = newpm; LEAVESUB(sv); @@ -2473,6 +2519,7 @@ PP(pp_leavesublv) PUTBACK; LEAVE; + cxstack_ix--; POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2931,7 +2978,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) HE* he; he = hv_fetch_ent(PL_stashcache, sv, 0, 0); if (he) { - stash = (HV*)SvIV(HeVAL(he)); + stash = INT2PTR(HV*,SvIV(HeVAL(he))); goto fetch; } } @@ -2957,7 +3004,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (!stash) packsv = sv; else { - SV* ref = newSViv((IV)stash); + SV* ref = newSViv(PTR2IV(stash)); hv_store(PL_stashcache, packname, packlen, ref, 0); } goto fetch; @@ -3016,7 +3063,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* the method name is unqualified or starts with SUPER:: */ packname = sep ? CopSTASHPV(PL_curcop) : stash ? HvNAME(stash) : packname; - packlen = strlen(packname); + if (!packname) + Perl_croak(aTHX_ + "Can't use anonymous symbol table for method lookup"); + else + packlen = strlen(packname); } else { /* the method name is qualified */