X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=4ce78678db43251fae8cd8a476957e6774565cc2;hb=4a39fcdeb5ff8d29084cd5cfbaed223de8adf4c1;hp=79855994b0045dd46292a4a49ba4dbce640733ce;hpb=6ab58e4d47c419dca1df070f2fa15786b3285750;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 7985599..4ce7867 100644 --- a/pp.c +++ b/pp.c @@ -1,6 +1,7 @@ /* pp.c * - * Copyright (c) 1991-2003, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 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. @@ -105,12 +106,7 @@ PP(pp_padhv) RETURNOP(do_kv()); } else if (gimme == G_SCALAR) { - SV* sv = sv_newmortal(); - if (HvFILL((HV*)TARG)) - Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", - (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); - else - sv_setiv(sv, 0); + SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG); SETs(sv); } RETURN; @@ -172,6 +168,12 @@ PP(pp_rv2gv) } if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); + if (SvPVX(sv)) { + (void)SvOOK_off(sv); /* backoff */ + if (SvLEN(sv)) + Safefree(SvPVX(sv)); + SvLEN(sv)=SvCUR(sv)=0; + } SvRV(sv) = (SV*)gv; SvROK_on(sv); SvSETMAGIC(sv); @@ -181,7 +183,7 @@ PP(pp_rv2gv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a symbol"); if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); RETSETUNDEF; } sym = SvPV(sv,len); @@ -242,7 +244,7 @@ PP(pp_rv2sv) PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); + report_uninit(sv); RETSETUNDEF; } sym = SvPV(sv, len); @@ -590,8 +592,12 @@ PP(pp_gelem) sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); break; case 'P': - if (strEQ(elem, "PACKAGE")) - sv = newSVpv(HvNAME(GvSTASH(gv)), 0); + if (strEQ(elem, "PACKAGE")) { + if (HvNAME(GvSTASH(gv))) + sv = newSVpv(HvNAME(GvSTASH(gv)), 0); + else + sv = newSVpv("__ANON__",0); + } break; case 'S': if (strEQ(elem, "SCALAR")) @@ -680,6 +686,8 @@ PP(pp_trans) if (PL_op->op_flags & OPf_STACKED) sv = POPs; + else if (PL_op->op_private & OPpTARGET_MY) + sv = GETTARGET; else { sv = DEFSV; EXTEND(SP,1); @@ -828,7 +836,7 @@ PP(pp_undef) PP(pp_predec) { dSP; - if (SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -845,7 +853,7 @@ PP(pp_predec) PP(pp_postinc) { dSP; dTARGET; - if (SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) @@ -867,7 +875,7 @@ PP(pp_postinc) PP(pp_postdec) { dSP; dTARGET; - if (SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) @@ -964,6 +972,7 @@ PP(pp_pow) register unsigned int highbit = 8 * sizeof(UV); register unsigned int lowbit = 0; register unsigned int diff; + bool odd_power = (bool)(power & 1); while ((diff = (highbit - lowbit) >> 1)) { if (baseuv & ~((1 << (lowbit + diff)) - 1)) lowbit += diff; @@ -986,7 +995,7 @@ PP(pp_pow) } } SP--; - if (baseuok || !(power & 1)) + if (baseuok || !odd_power) /* answer is positive */ SETu( result ); else if (result <= (UV)IV_MAX) @@ -1383,12 +1392,18 @@ PP(pp_repeat) dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register IV count = POPi; + if (count < 0) + count = 0; if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; I32 max; + static const char list_extend[] = "panic: list extend"; max = items * count; + MEM_WRAP_CHECK_1(max, SV*, list_extend); + if (items > 0 && max > 0 && (max < items || max < count)) + Perl_croak(aTHX_ list_extend); MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { @@ -1441,6 +1456,7 @@ PP(pp_repeat) if (count < 1) SvCUR_set(TARG, 0); else { + MEM_WRAP_CHECK_1(count, len, "panic: string extend"); SvGROW(TARG, (count * len) + 1); repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); SvCUR(TARG) *= count; @@ -2199,13 +2215,15 @@ PP(pp_bit_and) dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; + if (SvGMAGICAL(left)) mg_get(left); + if (SvGMAGICAL(right)) mg_get(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV i = SvIV(left) & SvIV(right); + IV i = SvIV_nomg(left) & SvIV_nomg(right); SETi(i); } else { - UV u = SvUV(left) & SvUV(right); + UV u = SvUV_nomg(left) & SvUV_nomg(right); SETu(u); } } @@ -2222,13 +2240,15 @@ PP(pp_bit_xor) dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; + if (SvGMAGICAL(left)) mg_get(left); + if (SvGMAGICAL(right)) mg_get(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right); SETi(i); } else { - UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right); SETu(u); } } @@ -2245,13 +2265,15 @@ PP(pp_bit_or) dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; + if (SvGMAGICAL(left)) mg_get(left); + if (SvGMAGICAL(right)) mg_get(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right); SETi(i); } else { - UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right); SETu(u); } } @@ -2346,13 +2368,15 @@ PP(pp_complement) dSP; dTARGET; tryAMAGICun(compl); { dTOPss; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { - IV i = ~SvIV(sv); + IV i = ~SvIV_nomg(sv); SETi(i); } else { - UV u = ~SvUV(sv); + UV u = ~SvUV_nomg(sv); SETu(u); } } @@ -2361,7 +2385,8 @@ PP(pp_complement) register I32 anum; STRLEN len; - SvSetSV(TARG, sv); + (void)SvPV_nomg(sv,len); /* force check for uninit var */ + sv_setsv_nomg(TARG, sv); tmps = (U8*)SvPV_force(TARG, len); anum = len; if (SvUTF8(TARG)) { @@ -2408,6 +2433,7 @@ PP(pp_complement) *result = '\0'; result -= nchar; sv_setpvn(TARG, (char*)result, nchar); + SvUTF8_off(TARG); } Safefree(result); SETs(TARG); @@ -2719,87 +2745,6 @@ PP(pp_srand) RETPUSHYES; } -STATIC U32 -S_seed(pTHX) -{ - /* - * This is really just a quick hack which grabs various garbage - * values. It really should be a real hash algorithm which - * spreads the effect of every input bit onto every output bit, - * if someone who knows about such things would bother to write it. - * Might be a good idea to add that function to CORE as well. - * No numbers below come from careful analysis or anything here, - * except they are primes and SEED_C1 > 1E6 to get a full-width - * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should - * probably be bigger too. - */ -#if RANDBITS > 16 -# define SEED_C1 1000003 -#define SEED_C4 73819 -#else -# define SEED_C1 25747 -#define SEED_C4 20639 -#endif -#define SEED_C2 3 -#define SEED_C3 269 -#define SEED_C5 26107 - -#ifndef PERL_NO_DEV_RANDOM - int fd; -#endif - U32 u; -#ifdef VMS -# include - /* when[] = (low 32 bits, high 32 bits) of time since epoch - * in 100-ns units, typically incremented ever 10 ms. */ - unsigned int when[2]; -#else -# ifdef HAS_GETTIMEOFDAY - struct timeval when; -# else - Time_t when; -# endif -#endif - -/* This test is an escape hatch, this symbol isn't set by Configure. */ -#ifndef PERL_NO_DEV_RANDOM -#ifndef PERL_RANDOM_DEVICE - /* /dev/random isn't used by default because reads from it will block - * if there isn't enough entropy available. You can compile with - * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there - * is enough real entropy to fill the seed. */ -# define PERL_RANDOM_DEVICE "/dev/urandom" -#endif - fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); - if (fd != -1) { - if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) - u = 0; - PerlLIO_close(fd); - if (u) - return u; - } -#endif - -#ifdef VMS - _ckvmssts(sys$gettim(when)); - u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; -#else -# ifdef HAS_GETTIMEOFDAY - PerlProc_gettimeofday(&when,NULL); - u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; -# else - (void)time(&when); - u = (U32)SEED_C1 * when; -# endif -#endif - u += SEED_C3 * (U32)PerlProc_getpid(); - u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); -#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ - u += SEED_C5 * (U32)PTR2UV(&when); -#endif - return u; -} - PP(pp_exp) { dSP; dTARGET; tryAMAGICun(exp); @@ -2844,28 +2789,6 @@ PP(pp_sqrt) } } -/* - * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2. - * These need to be revisited when a newer toolchain becomes available. - */ -#if defined(__sparc64__) && defined(__GNUC__) -# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96) -# undef SPARC64_MODF_WORKAROUND -# define SPARC64_MODF_WORKAROUND 1 -# endif -#endif - -#if defined(SPARC64_MODF_WORKAROUND) -static NV -sparc64_workaround_modf(NV theVal, NV *theIntRes) -{ - NV res, ret; - ret = Perl_modf(theVal, &res); - *theIntRes = res; - return ret; -} -#endif - PP(pp_int) { dSP; dTARGET; tryAMAGICun(int); @@ -2889,51 +2812,14 @@ PP(pp_int) if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); } else { -#if defined(SPARC64_MODF_WORKAROUND) - (void)sparc64_workaround_modf(value, &value); -#else -# if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) -# ifdef HAS_MODFL_POW32_BUG -/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */ - { - NV offset = Perl_modf(value, &value); - (void)Perl_modf(offset, &offset); - value += offset; - } -# else - (void)Perl_modf(value, &value); -# endif -# else - double tmp = (double)value; - (void)Perl_modf(tmp, &tmp); - value = (NV)tmp; -# endif -#endif - SETn(value); + SETn(Perl_floor(value)); } } else { if (value > (NV)IV_MIN - 0.5) { SETi(I_V(value)); } else { -#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) -# ifdef HAS_MODFL_POW32_BUG -/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */ - { - NV offset = Perl_modf(-value, &value); - (void)Perl_modf(offset, &offset); - value += offset; - } -# else - (void)Perl_modf(-value, &value); -# endif - value = -value; -#else - double tmp = (double)value; - (void)Perl_modf(-tmp, &tmp); - value = -(NV)tmp; -#endif - SETn(value); + SETn(Perl_ceil(value)); } } } @@ -3158,6 +3044,19 @@ PP(pp_substr) if (utf8_curlen) sv_pos_u2b(sv, &pos, &rem); tmps += pos; + /* we either return a PV or an LV. If the TARG hasn't been used + * before, or is of that type, reuse it; otherwise use a mortal + * instead. Note that LVs can have an extended lifetime, so also + * dont reuse if refcount > 1 (bug #20933) */ + if (SvTYPE(TARG) > SVt_NULL) { + if ( (SvTYPE(TARG) == SVt_PVLV) + ? (!lvalue || SvREFCNT(TARG) > 1) + : lvalue) + { + TARG = sv_newmortal(); + } + } + sv_setpvn(TARG, tmps, rem); #ifdef USE_LOCALE_COLLATE sv_unmagic(TARG, PERL_MAGIC_collxfrm); @@ -3194,12 +3093,12 @@ PP(pp_substr) sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } - if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */ - TARG = sv_newmortal(); if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0); } + else + (void)SvOK_off(TARG); LvTYPE(TARG) = 'x'; if (LvTARG(TARG) != sv) { @@ -3387,7 +3286,8 @@ PP(pp_chr) tmps = SvPVX(TARG); if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) || memEQ(tmps, "\xef\xbf\xbd\0", 4)) { - SvGROW(TARG,3); + SvGROW(TARG, 3); + tmps = SvPVX(TARG); SvCUR_set(TARG, 2); *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value); *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value); @@ -3895,7 +3795,10 @@ PP(pp_delete) SP = ORIGMARK; else if (gimme == G_SCALAR) { MARK = ORIGMARK; - *++MARK = *SP; + if (SP > MARK) + *++MARK = *SP; + else + *++MARK = &PL_sv_undef; SP = MARK; } } @@ -4561,7 +4464,7 @@ PP(pp_split) s++; } } - 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; } @@ -4666,13 +4569,13 @@ PP(pp_split) } else { maxiters += slen * rx->nparens; - while (s < strend && --limit -/* && (!rx->check_substr - || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, - 0, NULL)))) -*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig, - 1 /* minend */, sv, NULL, 0)) + while (s < strend && --limit) { + PUTBACK; + i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0); + SPAGAIN; + if (i == 0) + break; TAINT_IF(RX_MATCH_TAINTED(rx)); if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; @@ -4711,7 +4614,6 @@ PP(pp_split) } } s = rx->endp[0] + orig; - PUTBACK; } } @@ -4737,7 +4639,7 @@ PP(pp_split) if (TOPs && !make_mortal) sv_2mortal(TOPs); iters--; - SP--; + *SP-- = &PL_sv_undef; } } @@ -4778,12 +4680,10 @@ PP(pp_split) if (gimme == G_ARRAY) RETURN; } - if (iters || !pm->op_pmreplroot) { - GETTARGET; - PUSHi(iters); - RETURN; - } - RETPUSHUNDEF; + + GETTARGET; + PUSHi(iters); + RETURN; } PP(pp_lock)