X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=c431ffad51c1dbdbf9da419b964e1934d1878fc8;hb=abec23e71b5d54dc73752d78864a1da13b1510e0;hp=4c05aab23a889df8a3d1a35a27356edf43d44d07;hpb=34aa158557bf899117e749eb5a8375ffe870f5d0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 4c05aab..c431ffa 100644 --- a/pp.c +++ b/pp.c @@ -1,6 +1,7 @@ /* pp.c * - * Copyright (c) 1991-2002, 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. @@ -106,6 +107,9 @@ PP(pp_padhv) } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); + if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied)) + Perl_croak(aTHX_ "Can't provide tied hash usage; " + "use keys(%%hash) to test if empty"); if (HvFILL((HV*)TARG)) Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); @@ -211,6 +215,7 @@ PP(pp_rv2gv) PP(pp_rv2sv) { + GV *gv = Nullgv; dSP; dTOPss; if (SvROK(sv)) { @@ -226,9 +231,9 @@ PP(pp_rv2sv) } } else { - GV *gv = (GV*)sv; char *sym; STRLEN len; + gv = (GV*)sv; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -265,8 +270,14 @@ PP(pp_rv2sv) sv = GvSV(gv); } if (PL_op->op_flags & OPf_MOD) { - if (PL_op->op_private & OPpLVAL_INTRO) - sv = save_scalar((GV*)TOPs); + if (PL_op->op_private & OPpLVAL_INTRO) { + if (cUNOP->op_first->op_type == OP_NULL) + sv = save_scalar((GV*)TOPs); + else if (gv) + sv = save_scalar(gv); + else + Perl_croak(aTHX_ PL_no_localize_ref); + } else if (PL_op->op_private & OPpDEREF) vivify_ref(sv, PL_op->op_private & OPpDEREF); } @@ -583,8 +594,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")) @@ -850,6 +865,7 @@ PP(pp_postinc) else sv_inc(TOPs); SvSETMAGIC(TOPs); + /* special case for undef: see thread at 2003-03/msg00536.html in archive */ if (!SvOK(TARG)) sv_setiv(TARG, 0); SETs(TARG); @@ -879,16 +895,15 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + dSP; dATARGET; #ifdef PERL_PRESERVE_IVUV - /* ** is implemented with pow. pow is floating point. Perl programmers - write 2 ** 31 and expect it to be 2147483648 - pow never made any guarantee to deliver a result to 53 (or whatever) - bits of accuracy. Which is unfortunate, as perl programmers expect it - to, and on some platforms (eg Irix with long doubles) it doesn't in - a very visible case. (2 ** 31, which a regression test uses) - So we'll implement power-of-2 ** +ve integer with multiplies, to avoid - these problems. */ + bool is_int = 0; +#endif + tryAMAGICbin(pow,opASSIGN); +#ifdef PERL_PRESERVE_IVUV + /* For integer to integer power, we do the calculation by hand wherever + we're sure it is safe; otherwise we call pow() and try to convert to + integer afterwards. */ { SvIV_please(TOPm1s); if (SvIOK(TOPm1s)) { @@ -920,10 +935,12 @@ PP(pp_pow) goto float_it; /* Can't do negative powers this way. */ } } - /* now we have integer ** positive integer. - foo & (foo - 1) is zero only for a power of 2. */ + /* now we have integer ** positive integer. */ + is_int = 1; + + /* foo & (foo - 1) is zero only for a power of 2. */ if (!(baseuv & (baseuv - 1))) { - /* We are raising power-of-2 to postive integer. + /* We are raising power-of-2 to a positive integer. The logic here will work for any base (even non-integer bases) but it can be less accurate than pow (base,power) or exp (power * log (base)) when the @@ -935,20 +952,6 @@ PP(pp_pow) NV base = baseuok ? baseuv : -(NV)baseuv; int n = 0; - /* The logic is this. - x ** n === x ** m1 * x ** m2 where n = m1 + m2 - so as 42 is 32 + 8 + 2 - x ** 42 can be written as - x ** 32 * x ** 8 * x ** 2 - I can calculate x ** 2, x ** 4, x ** 8 etc trivially: - x ** 2n is x ** n * x ** n - So I loop round, squaring x each time - (x, x ** 2, x ** 4, x ** 8) and multiply the result - by the x-value whenever that bit is set in the power. - To finish as soon as possible I zero bits in the power - when I've done them, so that power becomes zero when - I clear the last bit (no more to do), and the loop - terminates. */ for (; power; base *= base, n++) { /* Do I look like I trust gcc with long longs here? Do I hell. */ @@ -956,24 +959,70 @@ PP(pp_pow) if (power & bit) { result *= base; /* Only bother to clear the bit if it is set. */ - power &= ~bit; + power -= bit; /* Avoid squaring base again if we're done. */ if (power == 0) break; } } SP--; SETn( result ); + SvIV_please(TOPs); RETURN; - } - } - } + } else { + 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; + else + highbit -= diff; + } + /* we now have baseuv < 2 ** highbit */ + if (power * highbit <= 8 * sizeof(UV)) { + /* result will definitely fit in UV, so use UV math + on same algorithm as above */ + register UV result = 1; + register UV base = baseuv; + register int n = 0; + for (; power; base *= base, n++) { + register UV bit = (UV)1 << (UV)n; + if (power & bit) { + result *= base; + power -= bit; + if (power == 0) break; + } + } + SP--; + if (baseuok || !odd_power) + /* answer is positive */ + SETu( result ); + else if (result <= (UV)IV_MAX) + /* answer negative, fits in IV */ + SETi( -(IV)result ); + else if (result == (UV)IV_MIN) + /* 2's complement assumption: special case IV_MIN */ + SETi( IV_MIN ); + else + /* answer negative, doesn't fit */ + SETn( -(NV)result ); + RETURN; + } + } + } + } } - float_it: + float_it: #endif { - dPOPTOPnnrl; - SETn( Perl_pow( left, right) ); - RETURN; + dPOPTOPnnrl; + SETn( Perl_pow( left, right) ); +#ifdef PERL_PRESERVE_IVUV + if (is_int) + SvIV_please(TOPs); +#endif + RETURN; } } @@ -1197,7 +1246,7 @@ PP(pp_divide) } RETURN; } /* tried integer divide but it was not an integer result */ - } /* else (abs(result) < 1.0) or (both UVs in range for NV) */ + } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ } /* left wasn't SvIOK */ } /* right wasn't SvIOK */ #endif /* PERL_TRY_UV_DIVIDE */ @@ -2418,16 +2467,76 @@ PP(pp_i_divide) } } +STATIC +PP(pp_i_modulo_0) +{ + /* This is the vanilla old i_modulo. */ + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + { + dPOPTOPiirl; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + SETi( left % right ); + RETURN; + } +} + +#if defined(__GLIBC__) && IVSIZE == 8 +STATIC +PP(pp_i_modulo_1) +{ + /* This is the i_modulo with the workaround for the _moddi3 bug + * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). + * See below for pp_i_modulo. */ + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + { + dPOPTOPiirl; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + SETi( left % PERL_ABS(right) ); + RETURN; + } +} +#endif + PP(pp_i_modulo) { - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); - { - dPOPTOPiirl; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - SETi( left % right ); - RETURN; - } + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + { + dPOPTOPiirl; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + /* The assumption is to use hereafter the old vanilla version... */ + PL_op->op_ppaddr = + PL_ppaddr[OP_I_MODULO] = + &Perl_pp_i_modulo_0; + /* .. but if we have glibc, we might have a buggy _moddi3 + * (at least glicb 2.2.5 is known to have this bug), in other + * words our integer modulus with negative quad as the second + * argument might be broken. Test for this and re-patch the + * opcode dispatch table if that is the case, remembering to + * also apply the workaround so that this first round works + * right, too. See [perl #9402] for more information. */ +#if defined(__GLIBC__) && IVSIZE == 8 + { + IV l = 3; + IV r = -10; + /* Cannot do this check with inlined IV constants since + * that seems to work correctly even with the buggy glibc. */ + if (l % r == -3) { + /* Yikes, we have the bug. + * Patch in the workaround version. */ + PL_op->op_ppaddr = + PL_ppaddr[OP_I_MODULO] = + &Perl_pp_i_modulo_1; + /* Make certain we work right this time, too. */ + right = PERL_ABS(right); + } + } +#endif + SETi( left % right ); + RETURN; + } } PP(pp_i_add) @@ -2619,87 +2728,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); @@ -2744,28 +2772,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); @@ -2789,51 +2795,15 @@ 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); + /* This is maint, and we don't have Perl_ceil in perl.h */ + SETn(-Perl_floor(-value)); } } } @@ -3094,10 +3064,14 @@ 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) { @@ -3124,6 +3098,8 @@ PP(pp_vec) SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ + 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_vec, Nullch, 0); @@ -3278,8 +3254,20 @@ PP(pp_chr) *tmps++ = (char)value; *tmps = '\0'; (void)SvPOK_only(TARG); - if (PL_encoding) + if (PL_encoding && !IN_BYTES) { sv_recode_to_utf8(TARG, PL_encoding); + tmps = SvPVX(TARG); + if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) || + memEQ(tmps, "\xef\xbf\xbd\0", 4)) { + SvGROW(TARG, 3); + tmps = SvPVX(TARG); + SvCUR_set(TARG, 2); + *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value); + *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value); + *tmps = '\0'; + SvUTF8_on(TARG); + } + } XPUSHs(TARG); RETURN; } @@ -3303,6 +3291,24 @@ PP(pp_crypt) sv_utf8_downgrade(tsv, FALSE); tmps = SvPVX(tsv); } +# ifdef USE_ITHREADS +# ifdef HAS_CRYPT_R + if (!PL_reentrant_buffer->_crypt_struct_buffer) { + /* This should be threadsafe because in ithreads there is only + * one thread per interpreter. If this would not be true, + * we would need a mutex to protect this malloc. */ + PL_reentrant_buffer->_crypt_struct_buffer = + (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); +#if defined(__GLIBC__) || defined(__EMX__) + if (PL_reentrant_buffer->_crypt_struct_buffer) { + PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; + /* work around glibc-2.2.5 bug */ + PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; + } +#endif + } +# endif /* HAS_CRYPT_R */ +# endif /* USE_ITHREADS */ # ifdef FCRYPT sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); # else @@ -3323,7 +3329,10 @@ PP(pp_ucfirst) register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + SvGETMAGIC(sv); + if (DO_UTF8(sv) && + (s = (U8*)SvPV_nomg(sv, slen)) && slen && + UTF8_IS_START(*s)) { U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; STRLEN ulen; STRLEN tculen; @@ -3334,13 +3343,21 @@ PP(pp_ucfirst) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; + /* slen is the byte length of the whole SV. + * ulen is the byte length of the original Unicode character + * stored as UTF-8 at s. + * tculen is the byte length of the freshly titlecased + * Unicode character stored as UTF-8 at tmpbuf. + * We first set the result to be the titlecased character, + * and then append the rest of the SV data. */ sv_setpvn(TARG, (char*)tmpbuf, tculen); - sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + if (slen > ulen) + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); SETs(TARG); } else { - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); Copy(tmpbuf, s, tculen, U8); } } @@ -3348,11 +3365,11 @@ PP(pp_ucfirst) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); if (*s) { if (IN_LOCALE_RUNTIME) { TAINT; @@ -3363,8 +3380,7 @@ PP(pp_ucfirst) *s = toUPPER(*s); } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3375,7 +3391,10 @@ PP(pp_lcfirst) register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + SvGETMAGIC(sv); + if (DO_UTF8(sv) && + (s = (U8*)SvPV_nomg(sv, slen)) && slen && + UTF8_IS_START(*s)) { STRLEN ulen; U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; U8 *tend; @@ -3388,12 +3407,13 @@ PP(pp_lcfirst) if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); - sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); + if (slen > ulen) + sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); SETs(TARG); } else { - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); Copy(tmpbuf, s, ulen, U8); } } @@ -3401,11 +3421,11 @@ PP(pp_lcfirst) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, slen); + s = (U8*)SvPV_force_nomg(sv, slen); if (*s) { if (IN_LOCALE_RUNTIME) { TAINT; @@ -3416,8 +3436,7 @@ PP(pp_lcfirst) *s = toLOWER(*s); } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3428,6 +3447,7 @@ PP(pp_uc) register U8 *s; STRLEN len; + SvGETMAGIC(sv); if (DO_UTF8(sv)) { dTARGET; STRLEN ulen; @@ -3435,7 +3455,7 @@ PP(pp_uc) U8 *send; U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - s = (U8*)SvPV(sv,len); + s = (U8*)SvPV_nomg(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); @@ -3465,11 +3485,11 @@ PP(pp_uc) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, len); + s = (U8*)SvPV_force_nomg(sv, len); if (len) { register U8 *send = s + len; @@ -3485,8 +3505,7 @@ PP(pp_uc) } } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -3497,6 +3516,7 @@ PP(pp_lc) register U8 *s; STRLEN len; + SvGETMAGIC(sv); if (DO_UTF8(sv)) { dTARGET; STRLEN ulen; @@ -3504,7 +3524,7 @@ PP(pp_lc) U8 *send; U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; - s = (U8*)SvPV(sv,len); + s = (U8*)SvPV_nomg(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); @@ -3551,12 +3571,12 @@ PP(pp_lc) if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ - sv_setsv(TARG, sv); + sv_setsv_nomg(TARG, sv); sv = TARG; SETs(sv); } - s = (U8*)SvPV_force(sv, len); + s = (U8*)SvPV_force_nomg(sv, len); if (len) { register U8 *send = s + len; @@ -3572,8 +3592,7 @@ PP(pp_lc) } } } - if (SvSMAGICAL(sv)) - mg_set(sv); + SvSETMAGIC(sv); RETURN; } @@ -4367,7 +4386,7 @@ PP(pp_split) TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); - PL_reg_match_utf8 = do_utf8; + RX_MATCH_UTF8_set(rx, do_utf8); if (pm->op_pmreplroot) { #ifdef USE_ITHREADS @@ -4399,6 +4418,7 @@ PP(pp_split) } /* temporarily switch stacks */ SWITCHSTACK(PL_curstack, ary); + PL_curstackinfo->si_stack = ary; make_mortal = 0; } } @@ -4414,7 +4434,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; } @@ -4519,13 +4539,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; @@ -4596,6 +4616,7 @@ PP(pp_split) if (realarray) { if (!mg) { SWITCHSTACK(ary, oldstack); + PL_curstackinfo->si_stack = oldstack; if (SvSMAGICAL(ary)) { PUTBACK; mg_set((SV*)ary); @@ -4629,12 +4650,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)