X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c9d5ac959cdfa7a668b3bfbbc2b56923c316ef43..28f5ac64634a59c745f35fa344b1611121715c59:/pp_hot.c diff --git a/pp_hot.c b/pp_hot.c index 6bec999..5d43a79 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. @@ -19,10 +19,6 @@ #define PERL_IN_PP_HOT_C #include "perl.h" -#ifdef I_UNISTD -#include -#endif - /* Hot code. */ #ifdef USE_THREADS @@ -31,7 +27,7 @@ static void unset_cvowner(pTHXo_ void *cvarg); PP(pp_const) { - djSP; + dSP; XPUSHs(cSVOP_sv); RETURN; } @@ -47,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)); @@ -75,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 { @@ -106,7 +104,7 @@ PP(pp_and) PP(pp_sassign) { - djSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { SV *temp; @@ -121,7 +119,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - djSP; + dSP; if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); else @@ -141,61 +139,60 @@ PP(pp_unstack) PP(pp_concat) { - djSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN len; - char *s; - bool left_utf = DO_UTF8(left); - bool right_utf = DO_UTF8(right); + STRLEN llen; + char* lpv; + bool lbyte; + STRLEN rlen; + char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ + bool rbyte = !SvUTF8(right); - if (TARG != left) { - if (right_utf && !left_utf) - sv_utf8_upgrade(left); - s = SvPV(left,len); - SvUTF8_off(TARG); - 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); - SETs(TARG); - RETURN; - } - sv_setpvn(TARG,s,len); + if (TARG == right && right != left) { + right = sv_2mortal(newSVpvn(rpv, rlen)); + rpv = SvPV(right, rlen); /* no point setting UTF8 here */ } - else if (SvGMAGICAL(TARG)) { - mg_get(TARG); - if (right_utf && !left_utf) - sv_utf8_upgrade(left); + + if (TARG != left) { + lpv = SvPV(left, llen); /* mg_get(left) may happen here */ + lbyte = !SvUTF8(left); + sv_setpvn(TARG, lpv, llen); + if (!lbyte) + SvUTF8_on(TARG); + else + SvUTF8_off(TARG); } - else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { - sv_setpv(TARG, ""); /* Suppress warning. */ - s = SvPV_force(TARG, len); + else { /* TARG == left */ + if (SvGMAGICAL(left)) + mg_get(left); /* or mg_get(left) may happen here */ + if (!SvOK(TARG)) + sv_setpv(left, ""); + lpv = SvPV_nomg(left, llen); + lbyte = !SvUTF8(left); } - if (left_utf && !right_utf) - sv_utf8_upgrade(right); - s = SvPV(right,len); - if (SvOK(TARG)) { + #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) && SvOK(TARG)) { + if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' + && (llen == 2 || !isDIGIT(lpv[llen - 3]))) + { + Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", + "about to append an integer to '19'"); } + } #endif - sv_catpvn(TARG,s,len); + + if (lbyte != rbyte) { + if (lbyte) + sv_utf8_upgrade_nomg(TARG); + else { + sv_utf8_upgrade_nomg(right); + rpv = SvPV(right, rlen); + } } - else - sv_setpvn(TARG,s,len); /* suppress warning */ - if (left_utf || right_utf) - SvUTF8_on(TARG); + sv_catpvn_nomg(TARG, rpv, rlen); + SETTARG; RETURN; } @@ -203,7 +200,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) @@ -222,7 +219,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 +234,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)); @@ -247,7 +313,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) && @@ -256,7 +322,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; @@ -264,7 +330,7 @@ PP(pp_preinc) PP(pp_or) { - djSP; + dSP; if (SvTRUE(TOPs)) RETURN; else { @@ -275,17 +341,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 = 0; + bool auvok = FALSE; + 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); @@ -299,7 +517,7 @@ PP(pp_aelemfast) PP(pp_join) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -309,7 +527,7 @@ PP(pp_join) PP(pp_pushre) { - djSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -330,20 +548,20 @@ 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; else gv = PL_defoutgv; - if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + 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,39 +582,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)); - } + if ((GvEGV(gv)) + && (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar))) + 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)); - } - else if (ckWARN(WARN_CLOSED)) - report_closed_fh(gv, io, "print", "filehandle"); + if (IoIFP(io)) + report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); + 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; } else { MARK++; - if (PL_ofslen) { + if (PL_ofs_sv && SvOK(PL_ofs_sv)) { while (MARK <= SP) { if (!do_print(*MARK, fp)) break; MARK++; if (MARK <= SP) { - if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) { + if (!do_print(PL_ofs_sv, fp)) { /* $, */ MARK--; break; } @@ -413,8 +625,8 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (PL_orslen) - if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp)) + if (PL_ors_sv && SvOK(PL_ors_sv)) + if (!do_print(PL_ors_sv, fp)) /* $\ */ goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) @@ -434,7 +646,7 @@ PP(pp_print) PP(pp_rv2av) { - djSP; dTOPss; + dSP; dTOPss; AV *av; if (SvROK(sv)) { @@ -448,6 +660,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) { @@ -456,10 +674,17 @@ 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; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -509,20 +734,27 @@ 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; + } } } 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*); } @@ -538,7 +770,7 @@ PP(pp_rv2av) PP(pp_rv2hv) { - djSP; dTOPss; + dSP; dTOPss; HV *hv; if (SvROK(sv)) { @@ -552,6 +784,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) { @@ -560,10 +798,17 @@ 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; - + if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN len; @@ -613,6 +858,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; + } } } @@ -723,7 +975,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; @@ -934,17 +1186,17 @@ PP(pp_aassign) PP(pp_qr) { - djSP; + dSP; register PMOP *pm = cPMOP; SV *rv = sv_newmortal(); SV *sv = newSVrv(rv, "Regexp"); - sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0); + sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp), PERL_MAGIC_qr,0,0); RETURNX(PUSHs(rv)); } PP(pp_match) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; register char *t; register char *s; @@ -967,11 +1219,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; @@ -995,23 +1248,23 @@ PP(pp_match) if ((global = pm->op_pmflags & PMf_GLOBAL)) { rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); + MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); 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; } } } - if ((gimme != G_ARRAY && !global && rx->nparens) + if ((!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)) { @@ -1027,13 +1280,15 @@ 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)) { + PL_bostr = truebase; s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); 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))) @@ -1056,27 +1311,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) { @@ -1086,7 +1339,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; @@ -1095,10 +1348,10 @@ play_it_again: if (global) { MAGIC* mg = 0; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) - mg = mg_find(TARG, 'g'); + mg = mg_find(TARG, PERL_MAGIC_regex_global); if (!mg) { - sv_magic(TARG, (SV*)0, 'g', Nullch, 0); - mg = mg_find(TARG, 'g'); + sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(TARG, PERL_MAGIC_regex_global); } if (rx->startp[0] != -1) { mg->mg_len = rx->endp[0]; @@ -1126,10 +1379,16 @@ 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; - } + } if (PL_sawampersand) { I32 off; @@ -1151,7 +1410,7 @@ nope: ret_no: if (global && !(pm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); + MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg) mg->mg_len = -1; } @@ -1175,7 +1434,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, PERL_MAGIC_tiedscalar))) { PUSHMARK(SP); XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); PUTBACK; @@ -1208,159 +1467,24 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } - else if (type == OP_GLOB) { - SV *tmpcmd = NEWSV(55, 0); - SV *tmpglob = POPs; - ENTER; - SAVEFREESV(tmpcmd); -#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ - /* since spawning off a process is a real performance hit */ - { -#include -#include -#include -#include - char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'}; - char vmsspec[NAM$C_MAXRSS+1]; - char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; - char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; - $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); - PerlIO *tmpfp; - STRLEN i; - struct dsc$descriptor_s wilddsc - = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - struct dsc$descriptor_vs rsdsc - = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt}; - unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0; - - /* We could find out if there's an explicit dev/dir or version - by peeking into lib$find_file's internal context at - ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb - but that's unsupported, so I don't want to do it now and - have it bite someone in the future. */ - strcat(tmpfnam,PerlLIO_tmpnam(NULL)); - cp = SvPV(tmpglob,i); - for (; i; i--) { - if (cp[i] == ';') hasver = 1; - if (cp[i] == '.') { - if (sts) hasver = 1; - else sts = 1; - } - if (cp[i] == '/') { - hasdir = isunix = 1; - break; - } - if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { - hasdir = 1; - break; - } - } - if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) { - Stat_t st; - if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode)) - ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL); - else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); - if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); - while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, - &dfltdsc,NULL,NULL,NULL))&1)) { - end = rstr + (unsigned long int) *rslt; - if (!hasver) while (*end != ';') end--; - *(end++) = '\n'; *end = '\0'; - for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); - if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); - begin = rstr; - } - else { - begin = end; - while (*(--begin) != ']' && *begin != '>') ; - ++begin; - } - ok = (PerlIO_puts(tmpfp,begin) != EOF); - } - if (cxt) (void)lib$find_file_end(&cxt); - if (ok && sts != RMS$_NMF && - sts != RMS$_DNF && sts != RMS$_FNF) ok = 0; - if (!ok) { - if (!(sts & 1)) { - SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); - } - PerlIO_close(tmpfp); - fp = NULL; - } - else { - PerlIO_rewind(tmpfp); - IoTYPE(io) = '<'; - IoIFP(io) = fp = tmpfp; - IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ - } - } - } -#else /* !VMS */ -#ifdef MACOS_TRADITIONAL - sv_setpv(tmpcmd, "glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, " |"); -#else -#ifdef DOSISH -#ifdef OS2 - sv_setpv(tmpcmd, "for a in "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); -#else -#ifdef DJGPP - sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ - sv_catsv(tmpcmd, tmpglob); -#else - sv_setpv(tmpcmd, "perlglob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, " |"); -#endif /* !DJGPP */ -#endif /* !OS2 */ -#else /* !DOSISH */ -#if defined(CSH) - sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); - sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); - sv_catsv(tmpcmd, tmpglob); - sv_catpv(tmpcmd, "' 2>/dev/null |"); -#else - sv_setpv(tmpcmd, "echo "); - sv_catsv(tmpcmd, tmpglob); -#if 'z' - 'a' == 25 - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); -#else - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); -#endif -#endif /* !CSH */ -#endif /* !DOSISH */ -#endif /* MACOS_TRADITIONAL */ - (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd), - FALSE, O_RDONLY, 0, Nullfp); - fp = IoIFP(io); -#endif /* !VMS */ - LEAVE; - } + else if (type == OP_GLOB) + fp = Perl_start_glob(aTHX_ POPs, io); } else if (type == OP_GLOB) SP--; - else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */ - && (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)); + 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) && io && !(IoFLAGS(io) & IOf_START)) { + if (ckWARN2(WARN_GLOB, WARN_CLOSED) + && (!io || !(IoFLAGS(io) & IOf_START))) { if (type == OP_GLOB) Perl_warner(aTHX_ WARN_GLOB, "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); @@ -1387,13 +1511,20 @@ Perl_do_readline(pTHX) offset = 0; } + /* This should not be marked tainted if the fp is marked clean */ +#define MAYBE_TAINT_LINE(io, sv) \ + if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ + TAINT; \ + SvTAINTED_on(sv); \ + } + /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ - || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \ - || ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { + PUTBACK; if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) { @@ -1414,17 +1545,17 @@ Perl_do_readline(pTHX) } if (gimme == G_SCALAR) { (void)SvOK_off(TARG); + SPAGAIN; PUSHTARG; } + MAYBE_TAINT_LINE(io, sv); RETURN; } - /* This should not be marked tainted if the fp is marked clean */ - if (!(IoFLAGS(io) & IOf_UNTAINT)) { - TAINT; - SvTAINTED_on(sv); - } + MAYBE_TAINT_LINE(io, sv); IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); + SPAGAIN; XPUSHs(sv); if (type == OP_GLOB) { char *tmps; @@ -1467,7 +1598,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - djSP; + dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1488,23 +1619,27 @@ 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; + I32 preeminent = 0; if (SvTYPE(hv) == SVt_PVHV) { - he = hv_fetch_ent(hv, keysv, lval && !defer, 0); + if (PL_op->op_private & OPpLVAL_INTRO) + preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 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; @@ -1520,7 +1655,7 @@ PP(pp_helem) lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0); + sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0); SvREFCNT_dec(key2); /* sv_magic() increments refcount */ LvTARG(lv) = SvREFCNT_inc(hv); LvTARGLEN(lv) = 1; @@ -1530,8 +1665,14 @@ PP(pp_helem) if (PL_op->op_private & OPpLVAL_INTRO) { if (HvNAME(hv) && isGV(*svp)) save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); - else - save_helem(hv, keysv, svp); + else { + if (!preeminent) { + STRLEN keylen; + char *key = SvPV(keysv, keylen); + SAVEDELETE(hv, savepvn(key,keylen), keylen); + } else + save_helem(hv, keysv, svp); + } } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); @@ -1551,7 +1692,7 @@ PP(pp_helem) PP(pp_leave) { - djSP; + dSP; register PERL_CONTEXT *cx; register SV **mark; SV **newsp; @@ -1607,7 +1748,7 @@ PP(pp_leave) PP(pp_iter) { - djSP; + dSP; register PERL_CONTEXT *cx; SV* sv; AV* av; @@ -1633,7 +1774,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 +1800,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 @@ -1677,13 +1818,21 @@ 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 (SvMAGICAL(av) || AvREIFY(av)) { + SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); + if (svp) + sv = *svp; + else + sv = Nullsv; + } + else { + sv = AvARRAY(av)[++cx->blk_loop.iterix]; + } + if (sv) SvTEMP_off(sv); else sv = &PL_sv_undef; - if (av != PL_curstack && SvIMMORTAL(sv)) { + if (av != PL_curstack && sv == &PL_sv_undef) { SV *lv = cx->blk_loop.iterlval; if (lv && SvREFCNT(lv) > 1) { SvREFCNT_dec(lv); @@ -1695,7 +1844,7 @@ PP(pp_iter) lv = cx->blk_loop.iterlval = NEWSV(26, 0); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, Nullsv, 'y', Nullch, 0); + sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); } LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = cx->blk_loop.iterix; @@ -1709,7 +1858,7 @@ PP(pp_iter) PP(pp_subst) { - djSP; dTARG; + dSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; register SV *dstr; @@ -1730,6 +1879,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; @@ -1738,7 +1889,11 @@ PP(pp_subst) else { 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) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) @@ -1756,12 +1911,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; @@ -1777,13 +1933,14 @@ PP(pp_subst) } orig = m = s; if (rx->reganch & RE_USE_INTUIT) { + PL_bostr = orig; s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); if (!s) 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)))) @@ -1887,7 +2044,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; @@ -1902,6 +2059,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); @@ -1910,6 +2069,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; @@ -1936,7 +2097,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); @@ -1944,6 +2106,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); @@ -1952,6 +2115,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); @@ -1961,7 +2126,7 @@ PP(pp_subst) goto ret_no; nope: -ret_no: +ret_no: SPAGAIN; PUSHs(&PL_sv_no); LEAVE_SCOPE(oldsave); @@ -1970,7 +2135,7 @@ ret_no: PP(pp_grepwhile) { - djSP; + dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2011,7 +2176,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2020,7 +2185,7 @@ PP(pp_leavesub) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (gimme == G_SCALAR) { MARK = newsp + 1; @@ -2056,7 +2221,7 @@ PP(pp_leavesub) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2069,7 +2234,7 @@ PP(pp_leavesub) * get any slower by more conditions */ PP(pp_leavesublv) { - djSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2078,7 +2243,7 @@ PP(pp_leavesublv) SV *sv; POPBLOCK(cx,newpm); - + TAINT_NOT; if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { @@ -2209,7 +2374,7 @@ PP(pp_leavesublv) } } PUTBACK; - + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ PL_curpm = newpm; /* ... and pop $1 et al */ @@ -2222,7 +2387,6 @@ PP(pp_leavesublv) STATIC CV * S_get_db_sub(pTHX_ SV **svp, CV *cv) { - dTHR; SV *dbsv = GvSV(PL_DBsub); if (!PERLDB_SUB_NN) { @@ -2230,13 +2394,15 @@ 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) ))) { /* 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); @@ -2257,7 +2423,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) PP(pp_entersub) { - djSP; dPOPss; + dSP; dPOPss; GV *gv; HV *stash; register CV *cv; @@ -2506,7 +2672,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; @@ -2536,7 +2702,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. */ @@ -2630,7 +2796,7 @@ try_autoload: EXTEND(SP, items); Copy(AvARRAY(av), SP + 1, items, SV*); SP += items; - PUTBACK ; + PUTBACK ; } } #endif /* USE_THREADS */ @@ -2659,6 +2825,7 @@ try_autoload: cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++MARK; @@ -2677,7 +2844,7 @@ try_autoload: } Copy(MARK,AvARRAY(av),items,SV*); AvFILLp(av) = items - 1; - + while (items--) { if (*MARK) SvTEMP_off(*MARK); @@ -2707,21 +2874,24 @@ 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)); } } PP(pp_aelem) { - djSP; + dSP; SV** svp; - I32 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) @@ -2735,7 +2905,7 @@ PP(pp_aelem) lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, Nullsv, 'y', Nullch, 0); + sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); LvTARG(lv) = SvREFCNT_inc(av); LvTARGOFF(lv) = elem; LvTARGLEN(lv) = 1; @@ -2787,7 +2957,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - djSP; + dSP; SV* sv = TOPs; if (SvROK(sv)) { @@ -2804,7 +2974,7 @@ PP(pp_method) PP(pp_method_named) { - djSP; + dSP; SV* sv = cSVOP->op_sv; U32 hash = SvUVX(sv); @@ -2821,27 +2991,32 @@ S_method_common(pTHX_ SV* meth, U32* hashp) HV* stash; char* name; STRLEN namelen; - char* packname; + char* packname = 0; STRLEN packlen; 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); + mg_get(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; + /* this isn't a reference */ packname = Nullch; if (!SvOK(sv) || !(packname = SvPV(sv, packlen)) || !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - if (!packname || - ((*(U8*)packname >= 0xc0 && DO_UTF8(sv)) + /* this isn't the name of a filehandle either */ + if (!packname || + ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) )) @@ -2850,12 +3025,15 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SvOK(sv) ? "without a package or object reference" : "on an undefined value"); } - stash = gv_stashpvn(packname, packlen, TRUE); + /* assume it's a package name */ + stash = gv_stashpvn(packname, packlen, FALSE); goto fetch; } + /* it _is_ a filehandle name -- replace with a reference */ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } + /* if we got here, ob should be a reference or a glob */ if (!ob || !(SvOBJECT(ob) || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) && SvOBJECT(ob)))) @@ -2867,6 +3045,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) stash = SvSTASH(ob); fetch: + /* NOTE: stash may be null, hope hv_fetch_ent and + gv_fetchmethod can cope (it seems they can) */ + /* shortcut for simple names */ if (hashp) { HE* he = hv_fetch_ent(stash, meth, 0, *hashp); @@ -2879,7 +3060,15 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } gv = gv_fetchmethod(stash, name); + if (!gv) { + /* This code tries to figure out just what went wrong with + gv_fetchmethod. It therefore needs to duplicate a lot of + the internals of that function. We can't move it inside + Perl_gv_fetchmethod_autoload(), however, since that would + cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we + don't want that. + */ char* leaf = name; char* sep = Nullch; char* p; @@ -2891,16 +3080,29 @@ S_method_common(pTHX_ SV* meth, U32* hashp) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash); + /* the method name is unqualified or starts with SUPER:: */ + packname = sep ? CopSTASHPV(PL_curcop) : + stash ? HvNAME(stash) : packname; packlen = strlen(packname); } else { + /* the method name is qualified */ packname = name; packlen = sep - name; } - Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"", - leaf, packname); + + /* we're relying on gv_fetchmethod not autovivifying the stash */ + if (gv_stashpvn(packname, packlen, FALSE)) { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%.*s\"", + leaf, (int)packlen, packname); + } + else { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%.*s\"" + " (perhaps you forgot to load \"%.*s\"?)", + leaf, (int)packlen, packname, (int)packlen, packname); + } } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } @@ -2910,9 +3112,6 @@ static void unset_cvowner(pTHXo_ void *cvarg) { register CV* cv = (CV *) cvarg; -#ifdef DEBUGGING - dTHR; -#endif /* DEBUGGING */ DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n", thr, cv, SvPEEK((SV*)cv))));