X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=70c6866fa79367e77aec1e00b77060b9dd598ff4;hb=36902e12d2b30e9370acddd3ddab927d842061cf;hp=25a0032533a7021a377c872cef0c41b72a0cd6cf;hpb=98a29390254d3cb423096b6282689bfe2a7e6a13;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 25a0032..70c6866 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -27,7 +27,7 @@ static void unset_cvowner(pTHXo_ void *cvarg); PP(pp_const) { - djSP; + dSP; XPUSHs(cSVOP_sv); RETURN; } @@ -43,7 +43,7 @@ PP(pp_nextstate) PP(pp_gvsv) { - djSP; + dSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP_gv)); @@ -71,27 +71,29 @@ PP(pp_pushmark) PP(pp_stringify) { - djSP; dTARGET; + dSP; dTARGET; STRLEN len; char *s; s = SvPV(TOPs,len); sv_setpvn(TARG,s,len); - if (SvUTF8(TOPs) && !IN_BYTE) + if (SvUTF8(TOPs)) SvUTF8_on(TARG); + else + SvUTF8_off(TARG); SETTARG; RETURN; } PP(pp_gv) { - djSP; + dSP; XPUSHs((SV*)cGVOP_gv); RETURN; } PP(pp_and) { - djSP; + dSP; if (!SvTRUE(TOPs)) RETURN; else { @@ -102,7 +104,7 @@ PP(pp_and) PP(pp_sassign) { - djSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -117,7 +119,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - djSP; + dSP; if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); else @@ -137,106 +139,55 @@ PP(pp_unstack) PP(pp_concat) { - djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN len; - U8 *s; - bool left_utf8; - bool right_utf8; + SV* rcopy = Nullsv; - if (TARG == right && SvGMAGICAL(right)) - mg_get(right); if (SvGMAGICAL(left)) mg_get(left); + if (TARG == right && SvGMAGICAL(right)) + mg_get(right); - left_utf8 = DO_UTF8(left); - right_utf8 = DO_UTF8(right); - - if (left_utf8 != right_utf8) { - if (TARG == right && !right_utf8) { - 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); - right_utf8 |= DO_UTF8(right); - if (TARG == right) { - /* Take a copy since we're about to overwrite TARG */ - olds = s = (U8*)savepvn((char*)s, len); - } - if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) { - if (SvREADONLY(left)) - left = sv_2mortal(newSVsv(left)); - else - sv_setpv(left, ""); /* Suppress warning. */ - } - l = (U8*)SvPV(left, targlen); - left_utf8 |= DO_UTF8(left); - if (TARG != left) - sv_setpvn(TARG, (char*)l, targlen); - if (!left_utf8) - sv_utf8_upgrade(TARG); - /* Extend TARG to length of right (s) */ - targlen = SvCUR(TARG) + len; - if (!right_utf8) { - /* plus one for each hi-byte char if we have to upgrade */ - for (c = s; c < s + len; c++) { - if (UTF8_IS_CONTINUED(*c)) - targlen++; - } - } - SvGROW(TARG, targlen+1); - /* And now copy, maybe upgrading right to UTF8 on the fly */ - if (right_utf8) - Copy(s, SvEND(TARG), len, U8); - else { - for (c = (U8*)SvEND(TARG); len--; s++) - c = uv_to_utf8(c, *s); - } - SvCUR_set(TARG, targlen); - *SvEND(TARG) = '\0'; - SvUTF8_on(TARG); - SETs(TARG); - Safefree(olds); - RETURN; - } - } - - if (TARG != left) { - s = (U8*)SvPV(left,len); - if (TARG == right) { - sv_insert(TARG, 0, 0, (char*)s, len); - SETs(TARG); - RETURN; + if (TARG == right && left != right) + /* Clone since otherwise we cannot prepend. */ + rcopy = sv_2mortal(newSVsv(right)); + + if (TARG != left) + sv_setsv(TARG, left); + + if (TARG == right) { + if (left == right) { + /* $right = $right . $right; */ + STRLEN rlen; + char *rpv = SvPV(right, rlen); + + sv_catpvn(TARG, rpv, rlen); } - sv_setpvn(TARG, (char *)s, len); + else /* $right = $left . $right; */ + sv_catsv(TARG, rcopy); } - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) - sv_setpv(TARG, ""); /* Suppress warning. */ - s = (U8*)SvPV(right,len); - if (SvOK(TARG)) { + else { + if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */ + sv_setpv(TARG, ""); + /* $other = $left . $right; */ + /* $left = $left . $right; */ + sv_catsv(TARG, right); + } + #if defined(PERL_Y2KWARN) - 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_Y2K, "Possible Y2K bug: %s", - "about to append an integer to '19'"); - } + 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_Y2K, "Possible Y2K bug: %s", + "about to append an integer to '19'"); } -#endif - sv_catpvn(TARG, (char *)s, len); } - else - sv_setpvn(TARG, (char *)s, len); /* suppress warning */ - if (left_utf8) - SvUTF8_on(TARG); +#endif + SETTARG; RETURN; } @@ -244,7 +195,7 @@ PP(pp_concat) PP(pp_padsv) { - djSP; dTARGET; + dSP; dTARGET; XPUSHs(TARG); if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) @@ -278,7 +229,76 @@ PP(pp_readline) PP(pp_eq) { - djSP; tryAMAGICbinSET(eq,0); + dSP; tryAMAGICbinSET(eq,0); +#ifndef NV_PRESERVES_UV + if (SvROK(TOPs) && SvROK(TOPm1s)) { + SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s))); + RETURN; + } +#endif +#ifdef PERL_PRESERVE_IVUV + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going + to have to use NV maths. Hence only attempt to coerce the + right argument if we know the left is integer. */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + bool auvok = SvUOK(TOPm1s); + bool buvok = SvUOK(TOPs); + + if (!auvok && !buvok) { /* ## IV == IV ## */ + IV aiv = SvIVX(TOPm1s); + IV biv = SvIVX(TOPs); + + SP--; + SETs(boolSV(aiv == biv)); + RETURN; + } + if (auvok && buvok) { /* ## UV == UV ## */ + UV auv = SvUVX(TOPm1s); + UV buv = SvUVX(TOPs); + + SP--; + SETs(boolSV(auv == buv)); + RETURN; + } + { /* ## Mixed IV,UV ## */ + IV iv; + UV uv; + + /* == is commutative so swap if needed (save code) */ + if (auvok) { + /* swap. top of stack (b) is the iv */ + iv = SvIVX(TOPs); + SP--; + if (iv < 0) { + /* As (a) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + uv = SvUVX(TOPs); + } else { + iv = SvIVX(TOPm1s); + SP--; + if (iv < 0) { + /* As (b) is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } + uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ + } + /* we know iv is >= 0 */ + if (uv > (UV) IV_MAX) { + SETs(&PL_sv_no); + RETURN; + } + SETs(boolSV((UV)iv == uv)); + RETURN; + } + } + } +#endif { dPOPnv; SETs(boolSV(TOPn == value)); @@ -288,7 +308,7 @@ PP(pp_eq) PP(pp_preinc) { - djSP; + dSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -297,7 +317,7 @@ PP(pp_preinc) ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } - else + else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ sv_inc(TOPs); SvSETMAGIC(TOPs); return NORMAL; @@ -305,7 +325,7 @@ PP(pp_preinc) PP(pp_or) { - djSP; + dSP; if (SvTRUE(TOPs)) RETURN; else { @@ -316,17 +336,169 @@ PP(pp_or) PP(pp_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); + useleft = USE_LEFT(TOPm1s); +#ifdef PERL_PRESERVE_IVUV + /* We must see if we can perform the addition with integers if possible, + as the integer code detects overflow while the NV code doesn't. + If either argument hasn't had a numeric conversion yet attempt to get + the IV. It's important to do this now, rather than just assuming that + it's not IOK as a PV of "9223372036854775806" may not take well to NV + addition, and an SV which is NOK, NV=6.0 ought to be coerced to + integer in case the second argument is IV=9223372036854775806 + We can (now) rely on sv_2iv to do the right thing, only setting the + public IOK flag if the value in the NV (or PV) slot is truly integer. + + A side effect is that this also aggressively prefers integer maths over + fp maths for integer values. + + How to detect overflow? + + C 99 section 6.2.6.1 says + + The range of nonnegative values of a signed integer type is a subrange + of the corresponding unsigned integer type, and the representation of + the same value in each type is the same. A computation involving + unsigned operands can never overflow, because a result that cannot be + represented by the resulting unsigned integer type is reduced modulo + the number that is one greater than the largest value that can be + represented by the resulting type. + + (the 9th paragraph) + + which I read as "unsigned ints wrap." + + signed integer overflow seems to be classed as "exception condition" + + If an exceptional condition occurs during the evaluation of an + expression (that is, if the result is not mathematically defined or not + in the range of representable values for its type), the behavior is + undefined. + + (6.5, the 5th paragraph) + + I had assumed that on 2s complement machines signed arithmetic would + wrap, hence coded pp_add and pp_subtract on the assumption that + everything perl builds on would be happy. After much wailing and + gnashing of teeth it would seem that irix64 knows its ANSI spec well, + knows that it doesn't need to, and doesn't. Bah. Anyway, the all- + unsigned code below is actually shorter than the old code. :-) + */ + + SvIV_please(TOPs); + if (SvIOK(TOPs)) { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + register UV auv; + bool auvok; + bool a_valid = 0; + + if (!useleft) { + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. + 0 is identity, + Could SETi or SETu right now, but space optimise by not adding + lots of code to speed up what is probably a rarish case. */ + } else { + /* Left operand is defined, so is it IV? */ + SvIV_please(TOPm1s); + if (SvIOK(TOPm1s)) { + if ((auvok = SvUOK(TOPm1s))) + auv = SvUVX(TOPm1s); + else { + register IV aiv = SvIVX(TOPm1s); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { /* 2s complement assumption for IV_MIN */ + auv = (UV)-aiv; + } + } + a_valid = 1; + } + } + if (a_valid) { + bool result_good = 0; + UV result; + register UV buv; + bool buvok = SvUOK(TOPs); + + if (buvok) + buv = SvUVX(TOPs); + else { + register IV biv = SvIVX(TOPs); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else + buv = (UV)-biv; + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independant of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a + b => (a + b) + A + b => -(a - b) + a + B => (a - b) + A + B => -(a + b) + all UV maths. negate result if A negative. + add if signs same, subtract if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; + } + } + } else { + /* Signs same */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } + if (result_good) { + SP--; + if (auvok) + SETu( result ); + else { + /* Negate result */ + if (result <= (UV)IV_MIN) + SETi( -(IV)result ); + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); + } + } + RETURN; + } /* Overflow, drop through to NVs. */ + } + } +#endif { - dPOPTOPnnrl_ul; - SETn( left + right ); - RETURN; + dPOPnv; + if (!useleft) { + /* left operand is undef, treat as zero. + 0.0 is identity. */ + SETn(value); + RETURN; + } + SETn( value + TOPn ); + RETURN; } } PP(pp_aelemfast) { - djSP; + dSP; AV *av = GvAV(cGVOP_gv); U32 lval = PL_op->op_flags & OPf_MOD; SV** svp = av_fetch(av, PL_op->op_private, lval); @@ -340,7 +512,7 @@ PP(pp_aelemfast) PP(pp_join) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -350,7 +522,7 @@ PP(pp_join) PP(pp_pushre) { - djSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -371,12 +543,11 @@ PP(pp_pushre) PP(pp_print) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; MAGIC *mg; - STRLEN n_a; if (PL_op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; @@ -469,7 +640,7 @@ PP(pp_print) PP(pp_rv2av) { - djSP; dTOPss; + dSP; dTOPss; AV *av; if (SvROK(sv)) { @@ -483,6 +654,12 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + SETs((SV*)av); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVAV) { @@ -491,6 +668,13 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } else { GV *gv; @@ -544,6 +728,13 @@ PP(pp_rv2av) SETs((SV*)av); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue" + " scalar context"); + SETs((SV*)av); + RETURN; + } } } @@ -573,7 +764,7 @@ PP(pp_rv2av) PP(pp_rv2hv) { - djSP; dTOPss; + dSP; dTOPss; HV *hv; if (SvROK(sv)) { @@ -587,6 +778,12 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + SETs((SV*)hv); + RETURN; + } } else { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { @@ -595,6 +792,13 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } else { GV *gv; @@ -648,6 +852,13 @@ PP(pp_rv2hv) SETs((SV*)hv); RETURN; } + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue" + " scalar context"); + SETs((SV*)hv); + RETURN; + } } } @@ -758,7 +969,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) PP(pp_aassign) { - djSP; + dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -969,7 +1180,7 @@ PP(pp_aassign) PP(pp_qr) { - djSP; + dSP; register PMOP *pm = cPMOP; SV *rv = sv_newmortal(); SV *sv = newSVrv(rv, "Regexp"); @@ -979,7 +1190,7 @@ PP(pp_qr) PP(pp_match) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; register char *t; register char *s; @@ -1002,11 +1213,12 @@ PP(pp_match) TARG = DEFSV; EXTEND(SP,1); } + PL_reg_sv = TARG; PUTBACK; /* EVAL blocks need stack_sp. */ s = SvPV(TARG, len); strend = s + len; if (!s) - DIE(aTHX_ "panic: do_match"); + DIE(aTHX_ "panic: pp_match"); rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; @@ -1043,7 +1255,7 @@ PP(pp_match) } } } - if ((gimme != G_ARRAY && !global && rx->nparens) + if ((!global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) r_flags |= REXEC_COPY_STR; if (SvSCREAM(TARG)) @@ -1062,7 +1274,8 @@ play_it_again: if (update_minmatch++) minmatch = had_zerolen; } - if (rx->reganch & RE_USE_INTUIT) { + if (rx->reganch & RE_USE_INTUIT && + DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); if (!s) @@ -1091,27 +1304,25 @@ play_it_again: RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { - I32 iters, i, len; + I32 nparens, i, len; - iters = rx->nparens; - if (global && !iters) + nparens = rx->nparens; + if (global && !nparens) i = 1; else i = 0; SPAGAIN; /* EVAL blocks could move the stack. */ - EXTEND(SP, iters + i); - EXTEND_MORTAL(iters + i); - for (i = !i; i <= iters; i++) { + EXTEND(SP, nparens + i); + EXTEND_MORTAL(nparens + i); + for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); /*SUPPRESS 560*/ if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { len = rx->endp[i] - rx->startp[i]; s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); - if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + if (DO_UTF8(TARG)) SvUTF8_on(*SP); - sv_utf8_downgrade(*SP, TRUE); - } } } if (global) { @@ -1121,7 +1332,7 @@ play_it_again: r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; } - else if (!iters) + else if (!nparens) XPUSHs(&PL_sv_yes); LEAVE_SCOPE(oldsave); RETURN; @@ -1161,7 +1372,13 @@ yup: /* Confirmed by INTUIT */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlen; + if (DO_UTF8(PL_reg_sv)) { + char *t = (char*)utf8_hop((U8*)s, rx->minlen); + rx->endp[0] = t - truebase; + } + else { + rx->endp[0] = s - truebase + rx->minlen; + } rx->sublen = strend - truebase; goto gotcha; } @@ -1248,10 +1465,9 @@ Perl_do_readline(pTHX) } else if (type == OP_GLOB) SP--; - else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ - && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout() - || fp == PerlIO_stderr())) + else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) { report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY); + } } if (!fp) { if (ckWARN2(WARN_GLOB, WARN_CLOSED) @@ -1301,6 +1517,7 @@ Perl_do_readline(pTHX) || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { + PUTBACK; if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) { @@ -1321,6 +1538,7 @@ Perl_do_readline(pTHX) } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); + SPAGAIN; PUSHTARG; } MAYBE_TAINT_LINE(io, sv); @@ -1330,6 +1548,7 @@ Perl_do_readline(pTHX) IoLINES(io)++; IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); + SPAGAIN; XPUSHs(sv); if (type == OP_GLOB) { char *tmps; @@ -1372,7 +1591,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1393,12 +1612,12 @@ PP(pp_enter) PP(pp_helem) { - djSP; + dSP; HE* he; SV **svp; SV *keysv = POPs; HV *hv = (HV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; @@ -1443,8 +1662,8 @@ PP(pp_helem) if (!preeminent) { STRLEN keylen; char *key = SvPV(keysv, keylen); - save_delete(hv, key, keylen); - } else + SAVEDELETE(hv, savepvn(key,keylen), keylen); + } else save_helem(hv, keysv, svp); } } @@ -1466,7 +1685,7 @@ PP(pp_helem) PP(pp_leave) { - djSP; + dSP; register PERL_CONTEXT *cx; register SV **mark; SV **newsp; @@ -1522,7 +1741,7 @@ PP(pp_leave) PP(pp_iter) { - djSP; + dSP; register PERL_CONTEXT *cx; SV* sv; AV* av; @@ -1624,7 +1843,7 @@ PP(pp_iter) PP(pp_subst) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; register SV *dstr; @@ -1645,6 +1864,8 @@ PP(pp_subst) STRLEN len; int force_on_match = 0; I32 oldsave = PL_savestack_ix; + bool do_utf8; + STRLEN slen; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; @@ -1654,6 +1875,8 @@ PP(pp_subst) TARG = DEFSV; EXTEND(SP,1); } + PL_reg_sv = TARG; + do_utf8 = DO_UTF8(PL_reg_sv); if (SvFAKE(TARG) && SvREADONLY(TARG)) sv_force_normal(TARG); if (SvREADONLY(TARG) @@ -1673,12 +1896,13 @@ PP(pp_subst) force_it: if (!pm || !s) - DIE(aTHX_ "panic: do_subst"); + DIE(aTHX_ "panic: pp_subst"); strend = s + len; - maxiters = 2*(strend - s) + 10; /* We can match twice at each - position, once with zero-length, - second time with non-zero. */ + slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len; + maxiters = 2 * slen + 10; /* We can match twice at each + position, once with zero-length, + second time with non-zero. */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; @@ -1819,6 +2043,8 @@ PP(pp_subst) if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { + bool isutf8; + if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -1827,6 +2053,8 @@ PP(pp_subst) rxtainted |= RX_MATCH_TAINTED(rx); dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); + if (DO_UTF8(TARG)) + SvUTF8_on(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; @@ -1853,7 +2081,8 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); + } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + TARG, NULL, r_flags)); sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); @@ -1861,6 +2090,7 @@ PP(pp_subst) SvPVX(TARG) = SvPVX(dstr); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); + isutf8 = DO_UTF8(dstr); SvPVX(dstr) = 0; sv_free(dstr); @@ -1869,6 +2099,8 @@ PP(pp_subst) PUSHs(sv_2mortal(newSViv((I32)iters))); (void)SvPOK_only(TARG); + if (isutf8) + SvUTF8_on(TARG); TAINT_IF(rxtainted); SvSETMAGIC(TARG); SvTAINT(TARG); @@ -1887,7 +2119,7 @@ ret_no: PP(pp_grepwhile) { - djSP; + dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -1928,7 +2160,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -1986,7 +2218,7 @@ PP(pp_leavesub) * get any slower by more conditions */ PP(pp_leavesublv) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2175,7 +2407,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) PP(pp_entersub) { - djSP; dPOPss; + dSP; dPOPss; GV *gv; HV *stash; register CV *cv; @@ -2633,14 +2865,17 @@ Perl_sub_crush_depth(pTHX_ CV *cv) PP(pp_aelem) { - djSP; + dSP; SV** svp; - IV elem = POPi; + SV* elemsv = POPs; + IV elem = SvIV(elemsv); AV* av = (AV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD; + U32 lval = PL_op->op_flags & OPf_MOD || LVRET; U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); SV *sv; + if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); if (elem > 0) elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) @@ -2706,7 +2941,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - djSP; + dSP; SV* sv = TOPs; if (SvROK(sv)) { @@ -2723,7 +2958,7 @@ PP(pp_method) PP(pp_method_named) { - djSP; + dSP; SV* sv = cSVOP->op_sv; U32 hash = SvUVX(sv); @@ -2763,7 +2998,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) !(ob=(SV*)GvIO(iogv))) { if (!packname || - ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) + ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) ))