X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=5ebea62a7b49dd72867d55b78924c78670f14795;hb=17f6277dd74eb819f9ad0089516167d0c4481e17;hp=eccf7eb0c9049956bdf58b6f9aaed9204a2857d8;hpb=f02c194e1a40f11d020685cd18b41e5261091b12;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index eccf7eb..5ebea62 100644 --- a/pp.c +++ b/pp.c @@ -1,7 +1,7 @@ /* pp.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 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. @@ -13,6 +13,13 @@ * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise */ +/* This file contains general pp ("push/pop") functions that execute the + * opcodes that make up a perl program. A typical pp function expects to + * find its arguments on the stack, and usually pushes its results onto + * the stack, hence the 'pp' terminology. Each OP structure contains + * a pointer to the relevant pp_foo() function. + */ + #include "EXTERN.h" #define PERL_IN_PP_C #include "perl.h" @@ -28,6 +35,14 @@ extern Pid_t getpid (void); #endif +/* + * Some BSDs and Cygwin default to POSIX math instead of IEEE. + * This switches them over to IEEE. + */ +#if defined(LIBM_LIB_VERSION) + _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_; +#endif + /* variations on pp_null */ PP(pp_stub) @@ -63,7 +78,7 @@ PP(pp_padav) } gimme = GIMME_V; if (gimme == G_ARRAY) { - I32 maxarg = AvFILL((AV*)TARG) + 1; + const I32 maxarg = AvFILL((AV*)TARG) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { U32 i; @@ -79,7 +94,7 @@ PP(pp_padav) } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); - I32 maxarg = AvFILL((AV*)TARG) + 1; + const I32 maxarg = AvFILL((AV*)TARG) + 1; sv_setiv(sv, maxarg); PUSHs(sv); } @@ -106,15 +121,7 @@ PP(pp_padhv) RETURNOP(do_kv()); } 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); - else - sv_setiv(sv, 0); + SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG); SETs(sv); } RETURN; @@ -148,9 +155,6 @@ PP(pp_rv2gv) } else { if (SvTYPE(sv) != SVt_PVGV) { - char *sym; - STRLEN len; - if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -160,23 +164,29 @@ PP(pp_rv2gv) /* If this is a 'my' scalar and flag is set then vivify * NI-S 1999/05/07 */ + if (SvREADONLY(sv)) + Perl_croak(aTHX_ PL_no_modify); if (PL_op->op_private & OPpDEREF) { - char *name; GV *gv; if (cUNOP->op_targ) { STRLEN len; SV *namesv = PAD_SV(cUNOP->op_targ); - name = SvPV(namesv, len); + const char *name = SvPV(namesv, len); gv = (GV*)NEWSV(0,0); gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } else { - name = CopSTASHPV(PL_curcop); + const char *name = CopSTASHPV(PL_curcop); gv = newGVgen(name); } if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); - SvRV(sv) = (SV*)gv; + if (SvPVX_const(sv)) { + SvPV_free(sv); + SvLEN_set(sv, 0); + SvCUR_set(sv, 0); + } + SvRV_set(sv, (SV*)gv); SvROK_on(sv); SvSETMAGIC(sv); goto wasref; @@ -185,25 +195,24 @@ 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); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); - if (!sv - && (!is_gv_magical(sym,len,0) - || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) - { + SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV); + if (!temp + && (!is_gv_magical_sv(sv,0) + || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) { RETSETUNDEF; } + sv = temp; } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, "a symbol"); - sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); + DIE(aTHX_ PL_no_symref_sv, sv, "a symbol"); + sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV); } } } @@ -231,8 +240,6 @@ PP(pp_rv2sv) } } else { - char *sym; - STRLEN len; gv = (GV*)sv; if (SvTYPE(gv) != SVt_PVGV) { @@ -246,25 +253,24 @@ 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); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); + gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV); if (!gv - && (!is_gv_magical(sym,len,0) - || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) + && (!is_gv_magical_sv(sv, 0) + || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV)))) { RETSETUNDEF; } } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, "a SCALAR"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); + DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); + gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV); } } sv = GvSV(gv); @@ -289,13 +295,13 @@ PP(pp_av2arylen) { dSP; AV *av = (AV*)TOPs; - SV *sv = AvARYLEN(av); - if (!sv) { - AvARYLEN(av) = sv = NEWSV(0,0); - sv_upgrade(sv, SVt_IV); - sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0); + SV **sv = Perl_av_arylen_p(aTHX_ (AV*)av); + if (!*sv) { + *sv = NEWSV(0,0); + sv_upgrade(*sv, SVt_PVMG); + sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0); } - SETs(sv); + SETs(*sv); RETURN; } @@ -370,18 +376,17 @@ PP(pp_prototype) ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { - char *s = SvPVX(TOPs); + const char *s = SvPVX_const(TOPs); if (strnEQ(s, "CORE::", 6)) { - int code; - - code = keyword(s + 6, SvCUR(TOPs) - 6); + const int code = keyword(s + 6, SvCUR(TOPs) - 6); if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) int i = 0, n = 0, seen_question = 0; I32 oa; char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ - if (code == -KEY_chop || code == -KEY_chomp) + if (code == -KEY_chop || code == -KEY_chomp + || code == -KEY_exec || code == -KEY_system) goto set; while (i < MAXO) { /* The slow way. */ if (strEQ(s + 6, PL_op_name[i]) @@ -399,8 +404,6 @@ PP(pp_prototype) seen_question = 1; str[n++] = ';'; } - else if (n && str[0] == ';' && seen_question) - goto set; /* XXXX system, exec */ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF /* But globs are already references (kinda) */ @@ -424,7 +427,7 @@ PP(pp_prototype) } cv = sv_2cv(TOPs, &stash, &gv, FALSE); if (cv && SvPOK(cv)) - ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv))); + ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv))); set: SETs(ret); RETURN; @@ -493,7 +496,7 @@ S_refto(pTHX_ SV *sv) } rv = sv_newmortal(); sv_upgrade(rv, SVt_RV); - SvRV(rv) = sv; + SvRV_set(rv, sv); SvROK_on(rv); return rv; } @@ -502,7 +505,7 @@ PP(pp_ref) { dSP; dTARGET; SV *sv; - char *pv; + const char *pv; sv = POPs; @@ -528,11 +531,11 @@ PP(pp_bless) else { SV *ssv = POPs; STRLEN len; - char *ptr; + const char *ptr; if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) Perl_croak(aTHX_ "Attempt to bless into a reference"); - ptr = SvPV(ssv,len); + ptr = SvPV_const(ssv,len); if (ckWARN(WARN_MISC) && len == 0) Perl_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); @@ -548,63 +551,63 @@ PP(pp_gelem) GV *gv; SV *sv; SV *tmpRef; - char *elem; + const char *elem; dSP; - STRLEN n_a; sv = POPs; - elem = SvPV(sv, n_a); + elem = SvPV_nolen_const(sv); gv = (GV*)POPs; tmpRef = Nullsv; sv = Nullsv; - switch (elem ? *elem : '\0') - { - case 'A': - if (strEQ(elem, "ARRAY")) - tmpRef = (SV*)GvAV(gv); - break; - case 'C': - if (strEQ(elem, "CODE")) - tmpRef = (SV*)GvCVu(gv); - break; - case 'F': - if (strEQ(elem, "FILEHANDLE")) { - /* finally deprecated in 5.8.0 */ - deprecate("*glob{FILEHANDLE}"); - tmpRef = (SV*)GvIOp(gv); + if (elem) { + /* elem will always be NUL terminated. */ + const char *elem2 = elem + 1; + switch (*elem) { + case 'A': + if (strEQ(elem2, "RRAY")) + tmpRef = (SV*)GvAV(gv); + break; + case 'C': + if (strEQ(elem2, "ODE")) + tmpRef = (SV*)GvCVu(gv); + break; + case 'F': + if (strEQ(elem2, "ILEHANDLE")) { + /* finally deprecated in 5.8.0 */ + deprecate("*glob{FILEHANDLE}"); + tmpRef = (SV*)GvIOp(gv); + } + else + if (strEQ(elem2, "ORMAT")) + tmpRef = (SV*)GvFORM(gv); + break; + case 'G': + if (strEQ(elem2, "LOB")) + tmpRef = (SV*)gv; + break; + case 'H': + if (strEQ(elem2, "ASH")) + tmpRef = (SV*)GvHV(gv); + break; + case 'I': + if (*elem2 == 'O' && !elem[2]) + tmpRef = (SV*)GvIOp(gv); + break; + case 'N': + if (strEQ(elem2, "AME")) + sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); + break; + case 'P': + if (strEQ(elem2, "ACKAGE")) { + const HEK *hek = HvNAME_HEK(GvSTASH(gv)); + sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8); + } + break; + case 'S': + if (strEQ(elem2, "CALAR")) + tmpRef = GvSV(gv); + break; } - else - if (strEQ(elem, "FORMAT")) - tmpRef = (SV*)GvFORM(gv); - break; - case 'G': - if (strEQ(elem, "GLOB")) - tmpRef = (SV*)gv; - break; - case 'H': - if (strEQ(elem, "HASH")) - tmpRef = (SV*)GvHV(gv); - break; - case 'I': - if (strEQ(elem, "IO")) - tmpRef = (SV*)GvIOp(gv); - break; - case 'N': - if (strEQ(elem, "NAME")) - sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); - break; - case 'P': - 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")) - tmpRef = GvSV(gv); - break; } if (tmpRef) sv = newRV(tmpRef); @@ -688,6 +691,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); @@ -820,13 +825,12 @@ PP(pp_undef) } break; default: - if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { - (void)SvOOK_off(sv); - Safefree(SvPVX(sv)); + if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { + SvPV_free(sv); SvPV_set(sv, Nullch); SvLEN_set(sv, 0); } - (void)SvOK_off(sv); + SvOK_off(sv); SvSETMAGIC(sv); } @@ -836,12 +840,12 @@ 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) { - --SvIVX(TOPs); + SvIV_set(TOPs, SvIVX(TOPs) - 1); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else @@ -853,13 +857,13 @@ 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) && SvIVX(TOPs) != IV_MAX) { - ++SvIVX(TOPs); + SvIV_set(TOPs, SvIVX(TOPs) + 1); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else @@ -875,13 +879,13 @@ 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) && SvIVX(TOPs) != IV_MIN) { - --SvIVX(TOPs); + SvIV_set(TOPs, SvIVX(TOPs) - 1); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else @@ -972,6 +976,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; @@ -994,7 +999,7 @@ PP(pp_pow) } } SP--; - if (baseuok || !(power & 1)) + if (baseuok || !odd_power) /* answer is positive */ SETu( result ); else if (result <= (UV)IV_MAX) @@ -1390,13 +1395,46 @@ PP(pp_repeat) { dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { - register IV count = POPi; + register IV count; + dPOPss; + if (SvGMAGICAL(sv)) + mg_get(sv); + if (SvIOKp(sv)) { + if (SvUOK(sv)) { + UV uv = SvUV(sv); + if (uv > IV_MAX) + count = IV_MAX; /* The best we can do? */ + else + count = uv; + } else { + IV iv = SvIV(sv); + if (iv < 0) + count = 0; + else + count = iv; + } + } + else if (SvNOKp(sv)) { + NV nv = SvNV(sv); + if (nv < 0.0) + count = 0; + else + count = (IV)nv; + } + else + count = SvIVx(sv); if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; I32 max; + static const char oom_list_extend[] = + "Out of memory during list extend"; max = items * count; + MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); + /* Did the max computation overflow? */ + if (items > 0 && max > 0 && (max < items || max < count)) + Perl_croak(aTHX_ oom_list_extend); MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { @@ -1441,6 +1479,8 @@ PP(pp_repeat) SV *tmpstr = POPs; STRLEN len; bool isutf; + static const char oom_string_extend[] = + "Out of memory during string extend"; SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); @@ -1449,9 +1489,13 @@ PP(pp_repeat) if (count < 1) SvCUR_set(TARG, 0); else { - SvGROW(TARG, (count * len) + 1); + STRLEN max = (UV)count * len; + if (len > ((MEM_SIZE)~0)/count) + Perl_croak(aTHX_ oom_string_extend); + MEM_WRAP_CHECK_1(max, char, oom_string_extend); + SvGROW(TARG, max + 1); repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); - SvCUR(TARG) *= count; + SvCUR_set(TARG, SvCUR(TARG) * count); } *SvEND(TARG) = '\0'; } @@ -1691,11 +1735,11 @@ PP(pp_lt) #ifdef PERL_PRESERVE_IVUV else #endif - if (SvROK(TOPs) && SvROK(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); - RETURN; - } + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { + SP--; + SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); + RETURN; + } #endif { dPOPnv; @@ -1769,7 +1813,7 @@ PP(pp_gt) #ifdef PERL_PRESERVE_IVUV else #endif - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); RETURN; @@ -1847,7 +1891,7 @@ PP(pp_le) #ifdef PERL_PRESERVE_IVUV else #endif - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); RETURN; @@ -1925,7 +1969,7 @@ PP(pp_ge) #ifdef PERL_PRESERVE_IVUV else #endif - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); RETURN; @@ -1942,7 +1986,7 @@ PP(pp_ne) { dSP; tryAMAGICbinSET(ne,0); #ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); RETURN; @@ -2011,7 +2055,7 @@ PP(pp_ncmp) { dSP; dTARGET; tryAMAGICbin(ncmp,0); #ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { UV right = PTR2UV(SvRV(POPs)); UV left = PTR2UV(SvRV(TOPs)); SETi((left > right) - (left < right)); @@ -2207,13 +2251,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); } } @@ -2230,13 +2276,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); } } @@ -2253,13 +2301,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); } } @@ -2308,7 +2358,7 @@ PP(pp_negate) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; - char *s = SvPV(sv, len); + const char *s = SvPV_const(sv, len); if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); @@ -2354,13 +2404,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); } } @@ -2369,7 +2421,8 @@ PP(pp_complement) register I32 anum; STRLEN len; - SvSetSV(TARG, sv); + (void)SvPV_nomg_const(sv,len); /* force check for uninit var */ + sv_setsv_nomg(TARG, sv); tmps = (U8*)SvPV_force(TARG, len); anum = len; if (SvUTF8(TARG)) { @@ -2416,6 +2469,7 @@ PP(pp_complement) *result = '\0'; result -= nchar; sv_setpvn(TARG, (char*)result, nchar); + SvUTF8_off(TARG); } Safefree(result); SETs(TARG); @@ -2470,7 +2524,7 @@ STATIC PP(pp_i_modulo_0) { /* This is the vanilla old i_modulo. */ - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -2487,7 +2541,7 @@ 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); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -2500,7 +2554,7 @@ PP(pp_i_modulo_1) PP(pp_i_modulo) { - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -2727,87 +2781,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); @@ -2852,28 +2825,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); @@ -2885,7 +2836,9 @@ PP(pp_int) else preferring IV has introduced a subtle behaviour change bug. OTOH relying on floating point to be accurate is a bug. */ - if (SvIOK(TOPs)) { + if (!SvOK(TOPs)) + SETu(0); + else if (SvIOK(TOPs)) { if (SvIsUV(TOPs)) { UV uv = TOPu; SETu(uv); @@ -2897,34 +2850,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); -#elif defined(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 - SETn(value); + SETn(Perl_floor(value)); } } else { if (value > (NV)IV_MIN - 0.5) { SETi(I_V(value)); } else { -#if defined(SPARC64_MODF_WORKAROUND) - (void)sparc64_workaround_modf(-value, &value); -#elif defined(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 - SETn(-value); + SETn(Perl_ceil(value)); } } } @@ -2939,7 +2872,9 @@ PP(pp_abs) /* This will cache the NV value if string isn't actually integer */ IV iv = TOPi; - if (SvIOK(TOPs)) { + if (!SvOK(TOPs)) + SETu(0); + else if (SvIOK(TOPs)) { /* IVX is precise */ if (SvIsUV(TOPs)) { SETu(TOPu); /* force it to be numeric only */ @@ -2970,14 +2905,14 @@ PP(pp_abs) PP(pp_hex) { dSP; dTARGET; - char *tmps; + const char *tmps; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; NV result_nv; UV result_uv; SV* sv = POPs; - tmps = (SvPVx(sv, len)); + tmps = (SvPV_const(sv, len)); if (DO_UTF8(sv)) { /* If Unicode, try to downgrade * If not possible, croak. */ @@ -2985,7 +2920,7 @@ PP(pp_hex) SvUTF8_on(tsv); sv_utf8_downgrade(tsv, FALSE); - tmps = SvPVX(tsv); + tmps = SvPV_const(tsv, len); } result_uv = grok_hex (tmps, &len, &flags, &result_nv); if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { @@ -3000,14 +2935,14 @@ PP(pp_hex) PP(pp_oct) { dSP; dTARGET; - char *tmps; + const char *tmps; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; NV result_nv; UV result_uv; SV* sv = POPs; - tmps = (SvPVx(sv, len)); + tmps = (SvPV_const(sv, len)); if (DO_UTF8(sv)) { /* If Unicode, try to downgrade * If not possible, croak. */ @@ -3015,7 +2950,7 @@ PP(pp_oct) SvUTF8_on(tsv); sv_utf8_downgrade(tsv, FALSE); - tmps = SvPVX(tsv); + tmps = SvPV_const(tsv, len); } while (*tmps && len && isSPACE(*tmps)) tmps++, len--; @@ -3061,11 +2996,11 @@ PP(pp_substr) I32 pos; I32 rem; I32 fail; - I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; - char *tmps; - I32 arybase = PL_curcop->cop_arybase; + const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; + const char *tmps; + const I32 arybase = PL_curcop->cop_arybase; SV *repl_sv = NULL; - char *repl = 0; + const char *repl = 0; STRLEN repl_len; int num_args = PL_op->op_private & 7; bool repl_need_utf8_upgrade = FALSE; @@ -3076,7 +3011,7 @@ PP(pp_substr) if (num_args > 2) { if (num_args > 3) { repl_sv = POPs; - repl = SvPV(repl_sv, repl_len); + repl = SvPV_const(repl_sv, repl_len); repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); } len = POPi; @@ -3092,7 +3027,7 @@ PP(pp_substr) else if (DO_UTF8(sv)) repl_need_utf8_upgrade = TRUE; } - tmps = SvPV(sv, curlen); + tmps = SvPV_const(sv, curlen); if (DO_UTF8(sv)) { utf8_curlen = sv_len_utf8(sv); if (utf8_curlen == curlen) @@ -3149,6 +3084,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); @@ -3161,7 +3109,7 @@ PP(pp_substr) if (repl_need_utf8_upgrade) { repl_sv_copy = newSVsv(repl_sv); sv_utf8_upgrade(repl_sv_copy); - repl = SvPV(repl_sv_copy, repl_len); + repl = SvPV_const(repl_sv_copy, repl_len); repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); } sv_insert(sv, pos, rem, repl, repl_len); @@ -3173,8 +3121,7 @@ PP(pp_substr) else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { - STRLEN n_a; - SvPV_force(sv,n_a); + SvPV_force_nolen(sv); if (ckWARN(WARN_SUBSTR)) Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "Attempt to use reference as lvalue in substr"); @@ -3185,12 +3132,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 + SvOK_off(TARG); LvTYPE(TARG) = 'x'; if (LvTARG(TARG) != sv) { @@ -3243,12 +3190,15 @@ PP(pp_index) dSP; dTARGET; SV *big; SV *little; + SV *temp = Nullsv; I32 offset; I32 retval; - char *tmps; - char *tmps2; + const char *tmps; + const char *tmps2; STRLEN biglen; I32 arybase = PL_curcop->cop_arybase; + int big_utf8; + int little_utf8; if (MAXARG < 3) offset = 0; @@ -3256,9 +3206,31 @@ PP(pp_index) offset = POPi - arybase; little = POPs; big = POPs; - tmps = SvPV(big, biglen); - if (offset > 0 && DO_UTF8(big)) + big_utf8 = DO_UTF8(big); + little_utf8 = DO_UTF8(little); + if (big_utf8 ^ little_utf8) { + /* One needs to be upgraded. */ + SV *bytes = little_utf8 ? big : little; + STRLEN len; + const char *p = SvPV_const(bytes, len); + + temp = newSVpvn(p, len); + + if (PL_encoding) { + sv_recode_to_utf8(temp, PL_encoding); + } else { + sv_utf8_upgrade(temp); + } + if (little_utf8) { + big = temp; + big_utf8 = TRUE; + } else { + little = temp; + } + } + if (big_utf8 && offset > 0) sv_pos_u2b(big, &offset, 0); + tmps = SvPV_const(big, biglen); if (offset < 0) offset = 0; else if (offset > (I32)biglen) @@ -3268,8 +3240,10 @@ PP(pp_index) retval = -1; else retval = tmps2 - tmps; - if (retval > 0 && DO_UTF8(big)) + if (retval > 0 && big_utf8) sv_pos_b2u(big, &retval); + if (temp) + SvREFCNT_dec(temp); PUSHi(retval + arybase); RETURN; } @@ -3279,24 +3253,50 @@ PP(pp_rindex) dSP; dTARGET; SV *big; SV *little; + SV *temp = Nullsv; STRLEN blen; STRLEN llen; I32 offset; I32 retval; - char *tmps; - char *tmps2; + const char *tmps; + const char *tmps2; I32 arybase = PL_curcop->cop_arybase; + int big_utf8; + int little_utf8; if (MAXARG >= 3) offset = POPi; little = POPs; big = POPs; - tmps2 = SvPV(little, llen); - tmps = SvPV(big, blen); + big_utf8 = DO_UTF8(big); + little_utf8 = DO_UTF8(little); + if (big_utf8 ^ little_utf8) { + /* One needs to be upgraded. */ + SV *bytes = little_utf8 ? big : little; + STRLEN len; + const char *p = SvPV_const(bytes, len); + + temp = newSVpvn(p, len); + + if (PL_encoding) { + sv_recode_to_utf8(temp, PL_encoding); + } else { + sv_utf8_upgrade(temp); + } + if (little_utf8) { + big = temp; + big_utf8 = TRUE; + } else { + little = temp; + } + } + tmps2 = SvPV_const(little, llen); + tmps = SvPV_const(big, blen); + if (MAXARG < 3) offset = blen; else { - if (offset > 0 && DO_UTF8(big)) + if (offset > 0 && big_utf8) sv_pos_u2b(big, &offset, 0); offset = offset - arybase + llen; } @@ -3309,8 +3309,10 @@ PP(pp_rindex) retval = -1; else retval = tmps2 - tmps; - if (retval > 0 && DO_UTF8(big)) + if (retval > 0 && big_utf8) sv_pos_b2u(big, &retval); + if (temp) + SvREFCNT_dec(temp); PUSHi(retval + arybase); RETURN; } @@ -3332,7 +3334,7 @@ PP(pp_ord) dSP; dTARGET; SV *argsv = POPs; STRLEN len; - U8 *s = (U8*)SvPVx(argsv, len); + const U8 *s = (U8*)SvPV_const(argsv, len); SV *tmpsv; if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { @@ -3342,7 +3344,7 @@ PP(pp_ord) } XPUSHu(DO_UTF8(argsv) ? - utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) : + utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) : (*s & 0xff)); RETURN; @@ -3352,14 +3354,27 @@ PP(pp_chr) { dSP; dTARGET; char *tmps; - UV value = POPu; + UV value; - (void)SvUPGRADE(TARG,SVt_PV); + if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0) + || + (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) { + if (IN_BYTES) { + value = POPu; /* chr(-1) eq chr(0xff), etc. */ + } else { + (void) POPs; /* Ignore the argument value. */ + value = UNICODE_REPLACEMENT; + } + } else { + value = POPu; + } + + SvUPGRADE(TARG,SVt_PV); if (value > 255 && !IN_BYTES) { SvGROW(TARG, (STRLEN)UNISKIP(value)+1); tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); - SvCUR_set(TARG, tmps - SvPVX(TARG)); + SvCUR_set(TARG, tmps - SvPVX_const(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); @@ -3393,12 +3408,11 @@ PP(pp_chr) PP(pp_crypt) { - dSP; dTARGET; #ifdef HAS_CRYPT + dSP; dTARGET; dPOPTOPssrl; - STRLEN n_a; STRLEN len; - char *tmps = SvPV(left, len); + const char *tmps = SvPV_const(left, len); if (DO_UTF8(left)) { /* If Unicode, try to downgrade. @@ -3408,7 +3422,7 @@ PP(pp_crypt) SvUTF8_on(tsv); sv_utf8_downgrade(tsv, FALSE); - tmps = SvPVX(tsv); + tmps = SvPV_const(tsv, len); } # ifdef USE_ITHREADS # ifdef HAS_CRYPT_R @@ -3429,9 +3443,9 @@ PP(pp_crypt) # endif /* HAS_CRYPT_R */ # endif /* USE_ITHREADS */ # ifdef FCRYPT - sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); + sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); # else - sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); + sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif SETs(TARG); RETURN; @@ -3445,14 +3459,14 @@ PP(pp_ucfirst) { dSP; SV *sv = TOPs; - register U8 *s; + const U8 *s; STRLEN slen; SvGETMAGIC(sv); if (DO_UTF8(sv) && - (s = (U8*)SvPV_nomg(sv, slen)) && slen && + (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen && UTF8_IS_START(*s)) { - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; STRLEN ulen; STRLEN tculen; @@ -3481,6 +3495,7 @@ PP(pp_ucfirst) } } else { + U8 *s1; if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ @@ -3488,15 +3503,15 @@ PP(pp_ucfirst) sv = TARG; SETs(sv); } - s = (U8*)SvPV_force_nomg(sv, slen); - if (*s) { + s1 = (U8*)SvPV_force_nomg(sv, slen); + if (*s1) { if (IN_LOCALE_RUNTIME) { TAINT; SvTAINTED_on(sv); - *s = toUPPER_LC(*s); + *s1 = toUPPER_LC(*s1); } else - *s = toUPPER(*s); + *s1 = toUPPER(*s1); } } SvSETMAGIC(sv); @@ -3507,15 +3522,15 @@ PP(pp_lcfirst) { dSP; SV *sv = TOPs; - register U8 *s; + const U8 *s; STRLEN slen; SvGETMAGIC(sv); if (DO_UTF8(sv) && - (s = (U8*)SvPV_nomg(sv, slen)) && slen && + (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen && UTF8_IS_START(*s)) { STRLEN ulen; - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; U8 *tend; UV uv; @@ -3537,6 +3552,7 @@ PP(pp_lcfirst) } } else { + U8 *s1; if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ @@ -3544,15 +3560,15 @@ PP(pp_lcfirst) sv = TARG; SETs(sv); } - s = (U8*)SvPV_force_nomg(sv, slen); - if (*s) { + s1 = (U8*)SvPV_force_nomg(sv, slen); + if (*s1) { if (IN_LOCALE_RUNTIME) { TAINT; SvTAINTED_on(sv); - *s = toLOWER_LC(*s); + *s1 = toLOWER_LC(*s1); } else - *s = toLOWER(*s); + *s1 = toLOWER(*s1); } } SvSETMAGIC(sv); @@ -3563,7 +3579,6 @@ PP(pp_uc) { dSP; SV *sv = TOPs; - register U8 *s; STRLEN len; SvGETMAGIC(sv); @@ -3571,36 +3586,52 @@ PP(pp_uc) dTARGET; STRLEN ulen; register U8 *d; - U8 *send; - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; + const U8 *s; + const U8 *send; + U8 tmpbuf[UTF8_MAXBYTES+1]; - s = (U8*)SvPV_nomg(sv,len); + s = (const U8*)SvPV_nomg_const(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); } else { - STRLEN nchar = utf8_length(s, s + len); + STRLEN min = len + 1; - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); + SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, min); (void)SvPOK_only(TARG); d = (U8*)SvPVX(TARG); send = s + len; while (s < send) { + STRLEN u = UTF8SKIP(s); + toUPPER_utf8(s, tmpbuf, &ulen); + if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { + /* If the eventually required minimum size outgrows + * the available space, we need to grow. */ + UV o = d - (U8*)SvPVX_const(TARG); + + /* If someone uppercases one million U+03B0s we + * SvGROW() one million times. Or we could try + * guessing how much to allocate without allocating + * too much. Such is life. */ + SvGROW(TARG, min); + d = (U8*)SvPVX(TARG) + o; + } Copy(tmpbuf, d, ulen, U8); d += ulen; - s += UTF8SKIP(s); + s += u; } *d = '\0'; SvUTF8_on(TARG); - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); SETs(TARG); } } else { + U8 *s; if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ @@ -3610,7 +3641,7 @@ PP(pp_uc) } s = (U8*)SvPV_force_nomg(sv, len); if (len) { - register U8 *send = s + len; + const register U8 *send = s + len; if (IN_LOCALE_RUNTIME) { TAINT; @@ -3632,34 +3663,36 @@ PP(pp_lc) { dSP; SV *sv = TOPs; - register U8 *s; STRLEN len; SvGETMAGIC(sv); if (DO_UTF8(sv)) { dTARGET; + const U8 *s; STRLEN ulen; register U8 *d; - U8 *send; - U8 tmpbuf[UTF8_MAXLEN_UCLC+1]; + const U8 *send; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - s = (U8*)SvPV_nomg(sv,len); + s = (const U8*)SvPV_nomg_const(sv,len); if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); SETs(TARG); } else { - STRLEN nchar = utf8_length(s, s + len); + STRLEN min = len + 1; - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1); + SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, min); (void)SvPOK_only(TARG); d = (U8*)SvPVX(TARG); send = s + len; while (s < send) { + STRLEN u = UTF8SKIP(s); UV uv = toLOWER_utf8(s, tmpbuf, &ulen); -#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */ + +#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */ if (uv == GREEK_CAPITAL_LETTER_SIGMA) { /* * Now if the sigma is NOT followed by @@ -3673,20 +3706,35 @@ PP(pp_lc) * then it should be mapped to 0x03C2, * (GREEK SMALL LETTER FINAL SIGMA), * instead of staying 0x03A3. - * See lib/unicore/SpecCase.txt. + * "should be": in other words, + * this is not implemented yet. + * See lib/unicore/SpecialCasing.txt. */ } + if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { + /* If the eventually required minimum size outgrows + * the available space, we need to grow. */ + UV o = d - (U8*)SvPVX_const(TARG); + + /* If someone lowercases one million U+0130s we + * SvGROW() one million times. Or we could try + * guessing how much to allocate without allocating. + * too much. Such is life. */ + SvGROW(TARG, min); + d = (U8*)SvPVX(TARG) + o; + } Copy(tmpbuf, d, ulen, U8); d += ulen; - s += UTF8SKIP(s); + s += u; } *d = '\0'; SvUTF8_on(TARG); - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); SETs(TARG); } } else { + U8 *s; if (!SvPADTMP(sv) || SvREADONLY(sv)) { dTARGET; SvUTF8_off(TARG); /* decontaminate */ @@ -3720,12 +3768,12 @@ PP(pp_quotemeta) dSP; dTARGET; SV *sv = TOPs; STRLEN len; - register char *s = SvPV(sv,len); + const register char *s = SvPV_const(sv,len); register char *d; SvUTF8_off(TARG); /* decontaminate */ if (len) { - (void)SvUPGRADE(TARG, SVt_PV); + SvUPGRADE(TARG, SVt_PV); SvGROW(TARG, (len * 2) + 1); d = SvPVX(TARG); if (DO_UTF8(sv)) { @@ -3755,7 +3803,7 @@ PP(pp_quotemeta) } } *d = '\0'; - SvCUR_set(TARG, d - SvPVX(TARG)); + SvCUR_set(TARG, d - SvPVX_const(TARG)); (void)SvPOK_only_UTF8(TARG); } else @@ -3805,7 +3853,7 @@ PP(pp_aslice) } if (GIMME != G_ARRAY) { MARK = ORIGMARK; - *++MARK = *SP; + *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; SP = MARK; } RETURN; @@ -3818,7 +3866,7 @@ PP(pp_each) dSP; HV *hash = (HV*)POPs; HE *entry; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; PUTBACK; /* might clobber stack_sp */ @@ -3857,8 +3905,8 @@ PP(pp_keys) PP(pp_delete) { dSP; - I32 gimme = GIMME_V; - I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; + const I32 gimme = GIMME_V; + const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; HV *hv; @@ -3887,7 +3935,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; } } @@ -3985,15 +4036,14 @@ PP(pp_hslice) if (lval) { if (!svp || *svp == &PL_sv_undef) { - STRLEN n_a; - DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem_sv, keysv); } if (localizing) { if (preeminent) save_helem(hv, keysv, svp); else { STRLEN keylen; - char *key = SvPV(keysv, keylen); + const char *key = SvPV_const(keysv, keylen); SAVEDELETE(hv, savepvn(key,keylen), keylen); } } @@ -4002,7 +4052,7 @@ PP(pp_hslice) } if (GIMME != G_ARRAY) { MARK = ORIGMARK; - *++MARK = *SP; + *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; SP = MARK; } RETURN; @@ -4109,7 +4159,7 @@ PP(pp_anonhash) PP(pp_splice) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; @@ -4178,6 +4228,12 @@ PP(pp_splice) if (newlen && !AvREAL(ary) && AvREIFY(ary)) av_reify(ary); + /* make new elements SVs now: avoid problems if they're from the array */ + for (dst = MARK, i = newlen; i; i--) { + SV *h = *dst; + *dst++ = newSVsv(h); + } + if (diff < 0) { /* shrinking the area */ if (newlen) { New(451, tmparyval, newlen, SV*); /* so remember insertion */ @@ -4217,7 +4273,7 @@ PP(pp_splice) *dst-- = *src--; } dst = AvARRAY(ary); - SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ + SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */ AvMAX(ary) += diff; } else { @@ -4234,11 +4290,7 @@ PP(pp_splice) dst[--i] = &PL_sv_undef; if (newlen) { - for (src = tmparyval, dst = AvARRAY(ary) + offset; - newlen; newlen--) { - *dst = NEWSV(46, 0); - sv_setsv(*dst++, *src++); - } + Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); Safefree(tmparyval); } } @@ -4258,7 +4310,7 @@ PP(pp_splice) dst = src - diff; Move(src, dst, offset, SV*); } - SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ + SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */ AvMAX(ary) += diff; AvFILLp(ary) += diff; } @@ -4277,10 +4329,10 @@ PP(pp_splice) } } - for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { - *dst = NEWSV(46, 0); - sv_setsv(*dst++, *src++); + if (newlen) { + Copy( MARK, AvARRAY(ary) + offset, newlen, SV* ); } + MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ if (length) { @@ -4314,7 +4366,7 @@ PP(pp_splice) PP(pp_push) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &PL_sv_undef; MAGIC *mg; @@ -4369,7 +4421,7 @@ PP(pp_shift) PP(pp_unshift) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; @@ -4387,8 +4439,7 @@ PP(pp_unshift) else { av_unshift(ary, SP - MARK); while (MARK < SP) { - sv = NEWSV(27, 0); - sv_setsv(sv, *++MARK); + sv = newSVsv(*++MARK); (void)av_store(ary, i++, sv); } } @@ -4419,17 +4470,22 @@ PP(pp_reverse) register I32 tmp; dTARGET; STRLEN len; + I32 padoff_du; SvUTF8_off(TARG); /* decontaminate */ if (SP - MARK > 1) do_join(TARG, &PL_sv_no, MARK, SP); else - sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV); + sv_setsv(TARG, (SP > MARK) + ? *SP + : (padoff_du = find_rundefsvoffset(), + (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR) + ? DEFSV : PAD_SVl(padoff_du))); up = SvPV_force(TARG, len); if (len > 1) { if (DO_UTF8(TARG)) { /* first reverse each character */ U8* s = (U8*)SvPVX(TARG); - U8* send = (U8*)(s + len); + const U8* send = (U8*)(s + len); while (s < send) { if (UTF8_IS_INVARIANT(*s)) { s++; @@ -4467,30 +4523,30 @@ PP(pp_reverse) PP(pp_split) { - dSP; dTARG; + dVAR; dSP; dTARG; AV *ary; register IV limit = POPi; /* note, negative is forever */ SV *sv = POPs; STRLEN len; - register char *s = SvPV(sv, len); + register const char *s = SvPV_const(sv, len); bool do_utf8 = DO_UTF8(sv); - char *strend = s + len; + const char *strend = s + len; register PMOP *pm; register REGEXP *rx; register SV *dstr; - register char *m; + register const char *m; I32 iters = 0; - STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); + const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); I32 maxiters = slen + 10; I32 i; - char *orig; + const char *orig; I32 origlimit = limit; I32 realarray = 0; I32 base; - AV *oldstack = PL_curstack; - I32 gimme = GIMME_V; - I32 oldsave = PL_savestack_ix; + const I32 gimme = GIMME_V; + const I32 oldsave = PL_savestack_ix; I32 make_mortal = 1; + bool multiline = 0; MAGIC *mg = (MAGIC *) NULL; #ifdef DEBUGGING @@ -4536,8 +4592,7 @@ PP(pp_split) AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } /* temporarily switch stacks */ - SWITCHSTACK(PL_curstack, ary); - PL_curstackinfo->si_stack = ary; + SAVESWITCHSTACK(PL_curstack, ary); make_mortal = 0; } } @@ -4553,9 +4608,8 @@ PP(pp_split) s++; } } - if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { - SAVEINT(PL_multiline); - PL_multiline = pm->op_pmflags & PMf_MULTILINE; + if (pm->op_pmflags & PMf_MULTILINE) { + multiline = 1; } if (!limit) @@ -4570,8 +4624,7 @@ PP(pp_split) if (m >= strend) break; - dstr = NEWSV(30, m-s); - sv_setpvn(dstr, s, m-s); + dstr = newSVpvn(s, m-s); if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4585,15 +4638,14 @@ PP(pp_split) ++s; } } - else if (strEQ("^", rx->precomp)) { + else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') { while (--limit) { - /*SUPPRESS 530*/ - for (m = s; m < strend && *m != '\n'; m++) ; + for (m = s; m < strend && *m != '\n'; m++) + ; m++; if (m >= strend) break; - dstr = NEWSV(30, m-s); - sv_setpvn(dstr, s, m-s); + dstr = newSVpvn(s, m-s); if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4611,15 +4663,13 @@ PP(pp_split) len = rx->minlen; if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { - STRLEN n_a; - char c = *SvPV(csv, n_a); + char c = *SvPV_nolen_const(csv); while (--limit) { - /*SUPPRESS 530*/ - for (m = s; m < strend && *m != c; m++) ; + for (m = s; m < strend && *m != c; m++) + ; if (m >= strend) break; - dstr = NEWSV(30, m-s); - sv_setpvn(dstr, s, m-s); + dstr = newSVpvn(s, m-s); if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4634,14 +4684,11 @@ PP(pp_split) } } else { -#ifndef lint while (s < strend && --limit && (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, - csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) -#endif + csv, multiline ? FBMrf_MULTILINE : 0)) ) { - dstr = NEWSV(31, m-s); - sv_setpvn(dstr, s, m-s); + dstr = newSVpvn(s, m-s); if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4658,13 +4705,14 @@ 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, (char*)s, (char*)strend, (char*)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; @@ -4674,8 +4722,7 @@ PP(pp_split) strend = s + (strend - m); } m = rx->startp[0] + orig; - dstr = NEWSV(32, m-s); - sv_setpvn(dstr, s, m-s); + dstr = newSVpvn(s, m-s); if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4690,8 +4737,7 @@ PP(pp_split) parens that didn't match -- they should be set to undef, not the empty string */ if (m >= orig && s >= orig) { - dstr = NEWSV(33, m-s); - sv_setpvn(dstr, s, m-s); + dstr = newSVpvn(s, m-s); } else dstr = &PL_sv_undef; /* undef, not "" */ @@ -4703,11 +4749,9 @@ PP(pp_split) } } s = rx->endp[0] + orig; - PUTBACK; } } - LEAVE_SCOPE(oldsave); iters = (SP - PL_stack_base) - base; if (iters > maxiters) DIE(aTHX_ "Split loop"); @@ -4715,8 +4759,7 @@ PP(pp_split) /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { STRLEN l = strend - s; - dstr = NEWSV(34, l); - sv_setpvn(dstr, s, l); + dstr = newSVpvn(s, l); if (make_mortal) sv_2mortal(dstr); if (do_utf8) @@ -4729,14 +4772,15 @@ PP(pp_split) if (TOPs && !make_mortal) sv_2mortal(TOPs); iters--; - SP--; + *SP-- = &PL_sv_undef; } } + PUTBACK; + LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */ + SPAGAIN; if (realarray) { if (!mg) { - SWITCHSTACK(ary, oldstack); - PL_curstackinfo->si_stack = oldstack; if (SvSMAGICAL(ary)) { PUTBACK; mg_set((SV*)ary); @@ -4794,3 +4838,13 @@ PP(pp_threadsv) { DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */