X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=c3874337e3a29a583cfc8823e5fd5f3adad57653;hb=f472eb5c07ed95306a11c98250bda17aae994339;hp=431dc9ac7b75f73b29a9133a6370be08a4bbf7aa;hpb=a6c403648ecd5cc72235fdb1e7535523a8ff2ac9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 431dc9a..c387433 100644 --- a/pp.c +++ b/pp.c @@ -13,6 +13,7 @@ */ #include "EXTERN.h" +#define PERL_IN_PP_C #include "perl.h" /* @@ -110,12 +111,6 @@ typedef unsigned UBW; # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) #endif -#ifndef PERL_OBJECT -static void doencodes _((SV* sv, char* s, I32 len)); -static SV* refto _((SV* sv)); -static U32 seed _((void)); -#endif - /* variations on pp_null */ #ifdef I_UNISTD @@ -191,12 +186,12 @@ PP(pp_padhv) RETURN; gimme = GIMME_V; if (gimme == G_ARRAY) { - RETURNOP(do_kv(ARGS)); + RETURNOP(do_kv()); } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); if (HvFILL((HV*)TARG)) - sv_setpvf(sv, "%ld/%ld", + Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); else sv_setiv(sv, 0); @@ -207,7 +202,7 @@ PP(pp_padhv) PP(pp_padany) { - DIE("NOT IMPL LINE %d",__LINE__); + DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); } /* Translations. */ @@ -229,7 +224,7 @@ PP(pp_rv2gv) sv = (SV*) gv; } else if (SvTYPE(sv) != SVt_PVGV) - DIE("Not a GLOB reference"); + DIE(aTHX_ "Not a GLOB reference"); } else { if (SvTYPE(sv) != SVt_PVGV) { @@ -246,25 +241,30 @@ PP(pp_rv2gv) * NI-S 1999/05/07 */ if (PL_op->op_private & OPpDEREF) { - GV *gv = (GV *) newSV(0); - STRLEN len = 0; - char *name = ""; - if (cUNOP->op_first->op_type == OP_PADSV) { - SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4); - name = SvPV(padname,len); + char *name; + GV *gv; + if (cUNOP->op_targ) { + STRLEN len; + SV *namesv = PL_curpad[cUNOP->op_targ]; + name = SvPV(namesv, len); + gv = (GV*)NEWSV(0,0); + gv_init(gv, CopSTASH(PL_curcop), name, len, 0); + } + else { + name = CopSTASHPV(PL_curcop); + gv = newGVgen(name); } - gv_init(gv, PL_curcop->cop_stash, name, len, 0); sv_upgrade(sv, SVt_RV); - SvRV(sv) = (SV *) gv; + SvRV(sv) = (SV*)gv; SvROK_on(sv); SvSETMAGIC(sv); goto wasref; - } + } if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_usym, "a symbol"); + DIE(aTHX_ PL_no_usym, "a symbol"); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); RETSETUNDEF; } sym = SvPV(sv, n_a); @@ -277,7 +277,7 @@ PP(pp_rv2gv) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "a symbol"); + DIE(aTHX_ PL_no_symref, sym, "a symbol"); sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); } } @@ -301,7 +301,7 @@ PP(pp_rv2sv) case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: - DIE("Not a SCALAR reference"); + DIE(aTHX_ "Not a SCALAR reference"); } } else { @@ -318,9 +318,9 @@ PP(pp_rv2sv) if (!SvOK(sv)) { if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_usym, "a SCALAR"); + DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) - warner(WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); RETSETUNDEF; } sym = SvPV(sv, n_a); @@ -333,7 +333,7 @@ PP(pp_rv2sv) } else { if (PL_op->op_private & HINT_STRICT_REFS) - DIE(PL_no_symref, sym, "a SCALAR"); + DIE(aTHX_ PL_no_symref, sym, "a SCALAR"); gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); } } @@ -411,6 +411,8 @@ PP(pp_rv2cv) if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); + if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; @@ -472,7 +474,7 @@ PP(pp_prototype) goto set; else { /* None such */ nonesuch: - croak("Cannot find an opnumber for \"%s\"", s+6); + DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } @@ -521,7 +523,7 @@ PP(pp_refgen) } STATIC SV* -refto(SV *sv) +S_refto(pTHX_ SV *sv) { SV* rv; @@ -533,6 +535,12 @@ refto(SV *sv) else (void)SvREFCNT_inc(sv); } + else if (SvTYPE(sv) == SVt_PVAV) { + if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) + av_reify((AV*)sv); + SvTEMP_off(sv); + (void)SvREFCNT_inc(sv); + } else if (SvPADTMP(sv)) sv = newSVsv(sv); else { @@ -572,13 +580,13 @@ PP(pp_bless) HV *stash; if (MAXARG == 1) - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); else { SV *ssv = POPs; STRLEN len; char *ptr = SvPV(ssv,len); if (ckWARN(WARN_UNSAFE) && len == 0) - warner(WARN_UNSAFE, + Perl_warner(aTHX_ WARN_UNSAFE, "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } @@ -694,7 +702,7 @@ PP(pp_study) snext = PL_screamnext; if (!sfirst || !snext) - DIE("do_study: out of memory"); + DIE(aTHX_ "do_study: out of memory"); for (ch = 256; ch; --ch) *sfirst++ = -1; @@ -825,7 +833,7 @@ PP(pp_undef) break; case SVt_PVCV: if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv)) - warner(WARN_UNSAFE, "Constant subroutine %s undefined", + Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: @@ -845,7 +853,7 @@ PP(pp_undef) Newz(602, gp, 1, GP); GvGP(sv) = gp_ref(gp); GvSV(sv) = NEWSV(72,0); - GvLINE(sv) = PL_curcop->cop_line; + GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); } @@ -868,7 +876,7 @@ PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -885,7 +893,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -905,8 +913,8 @@ PP(pp_postinc) PP(pp_postdec) { djSP; dTARGET; - if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(PL_no_modify); + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -948,15 +956,15 @@ PP(pp_divide) djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; - double value; + NV value; if (right == 0.0) - DIE("Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { IV k; - if ((double)I_V(left) == left && - (double)I_V(right) == right && + if ((NV)I_V(left) == left && + (NV)I_V(right) == right && (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; } @@ -981,8 +989,8 @@ PP(pp_modulo) bool left_neg; bool right_neg; bool use_double = 0; - double dright; - double dleft; + NV dright; + NV dleft; if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); @@ -1012,7 +1020,7 @@ PP(pp_modulo) } if (use_double) { - double dans; + NV dans; #if 1 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ @@ -1037,9 +1045,9 @@ PP(pp_modulo) dleft = floor(dleft + 0.5); if (!dright) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); - dans = fmod(dleft, dright); + dans = Perl_fmod(dleft, dright); if ((left_neg != right_neg) && dans) dans = dright - dans; if (right_neg) @@ -1051,7 +1059,7 @@ PP(pp_modulo) do_uv: if (!right) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); ans = left % right; if ((left_neg != right_neg) && ans) @@ -1062,7 +1070,7 @@ PP(pp_modulo) if (ans <= ~((UV)IV_MAX)+1) sv_setiv(TARG, ~ans+1); else - sv_setnv(TARG, -(double)ans); + sv_setnv(TARG, -(NV)ans); } else sv_setuv(TARG, ans); @@ -1498,7 +1506,7 @@ PP(pp_i_divide) { dPOPiv; if (value == 0) - DIE("Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); value = POPi / value; PUSHi( value ); RETURN; @@ -1511,7 +1519,7 @@ PP(pp_i_modulo) { dPOPTOPiirl; if (!right) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); SETi( left % right ); RETURN; } @@ -1629,7 +1637,7 @@ PP(pp_atan2) djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; - SETn(atan2(left, right)); + SETn(Perl_atan2(left, right)); RETURN; } } @@ -1638,9 +1646,9 @@ PP(pp_sin) { djSP; dTARGET; tryAMAGICun(sin); { - double value; + NV value; value = POPn; - value = sin(value); + value = Perl_sin(value); XPUSHn(value); RETURN; } @@ -1650,9 +1658,9 @@ PP(pp_cos) { djSP; dTARGET; tryAMAGICun(cos); { - double value; + NV value; value = POPn; - value = cos(value); + value = Perl_cos(value); XPUSHn(value); RETURN; } @@ -1670,13 +1678,13 @@ PP(pp_cos) */ #ifndef HAS_DRAND48_PROTO -extern double drand48 _((void)); +extern double drand48 (void); #endif PP(pp_rand) { djSP; dTARGET; - double value; + NV value; if (MAXARG < 1) value = 1.0; else @@ -1707,7 +1715,7 @@ PP(pp_srand) } STATIC U32 -seed(void) +S_seed(pTHX) { /* * This is really just a quick hack which grabs various garbage @@ -1780,10 +1788,10 @@ seed(void) u = (U32)SEED_C1 * when; # endif #endif - u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)PL_stack_sp; + 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)(UV)&when; + u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; } @@ -1792,9 +1800,9 @@ PP(pp_exp) { djSP; dTARGET; tryAMAGICun(exp); { - double value; + NV value; value = POPn; - value = exp(value); + value = Perl_exp(value); XPUSHn(value); RETURN; } @@ -1804,13 +1812,13 @@ PP(pp_log) { djSP; dTARGET; tryAMAGICun(log); { - double value; + NV value; value = POPn; if (value <= 0.0) { - SET_NUMERIC_STANDARD(); - DIE("Can't take log of %g", value); + RESTORE_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take log of %g", value); } - value = log(value); + value = Perl_log(value); XPUSHn(value); RETURN; } @@ -1820,13 +1828,13 @@ PP(pp_sqrt) { djSP; dTARGET; tryAMAGICun(sqrt); { - double value; + NV value; value = POPn; if (value < 0.0) { - SET_NUMERIC_STANDARD(); - DIE("Can't take sqrt of %g", value); + RESTORE_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take sqrt of %g", value); } - value = sqrt(value); + value = Perl_sqrt(value); XPUSHn(value); RETURN; } @@ -1836,7 +1844,7 @@ PP(pp_int) { djSP; dTARGET; { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { @@ -1845,9 +1853,9 @@ PP(pp_int) } else { if (value >= 0.0) - (void)modf(value, &value); + (void)Perl_modf(value, &value); else { - (void)modf(-value, &value); + (void)Perl_modf(-value, &value); value = -value; } iv = I_V(value); @@ -1864,7 +1872,7 @@ PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && @@ -1890,14 +1898,14 @@ PP(pp_hex) STRLEN n_a; tmps = POPpx; - XPUSHu(scan_hex(tmps, 99, &argtype)); + XPUSHn(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { djSP; dTARGET; - UV value; + NV value; I32 argtype; char *tmps; STRLEN n_a; @@ -1913,7 +1921,7 @@ PP(pp_oct) value = scan_bin(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - XPUSHu(value); + XPUSHn(value); RETURN; } @@ -2005,7 +2013,7 @@ PP(pp_substr) } if (fail < 0) { if (ckWARN(WARN_SUBSTR) || lvalue || repl) - warner(WARN_SUBSTR, "substr outside of string"); + Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { @@ -2013,13 +2021,15 @@ PP(pp_substr) sv_pos_u2b(sv, &pos, &rem); tmps += pos; sv_setpvn(TARG, tmps, rem); - if (lvalue) { /* it's an lvalue! */ + if (repl) + sv_insert(sv, pos, rem, repl, repl_len); + else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { STRLEN n_a; SvPV_force(sv,n_a); if (ckWARN(WARN_SUBSTR)) - warner(WARN_SUBSTR, + Perl_warner(aTHX_ WARN_SUBSTR, "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ @@ -2042,8 +2052,6 @@ PP(pp_substr) LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } - else if (repl) - sv_insert(sv, pos, rem, repl, repl_len); } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -2057,74 +2065,24 @@ PP(pp_vec) register I32 offset = POPi; register SV *src = POPs; I32 lvalue = PL_op->op_flags & OPf_MOD; - STRLEN srclen; - unsigned char *s = (unsigned char*)SvPV(src, srclen); - unsigned long retnum; - I32 len; - - SvTAINTED_off(TARG); /* decontaminate */ - offset *= size; /* turn into bit offset */ - len = (offset + size + 7) / 8; - if (offset < 0 || size < 1) - retnum = 0; - else { - if (lvalue) { /* it's an lvalue! */ - if (SvTYPE(TARG) < SVt_PVLV) { - sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, Nullsv, 'v', Nullch, 0); - } - LvTYPE(TARG) = 'v'; - if (LvTARG(TARG) != src) { - if (LvTARG(TARG)) - SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc(src); - } - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; - } - if (len > srclen) { - if (size <= 8) - retnum = 0; - else { - offset >>= 3; - if (size == 16) { - if (offset >= srclen) - retnum = 0; - else - retnum = (unsigned long) s[offset] << 8; - } - else if (size == 32) { - if (offset >= srclen) - retnum = 0; - else if (offset + 1 >= srclen) - retnum = (unsigned long) s[offset] << 24; - else if (offset + 2 >= srclen) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16); - else - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8); - } - } + SvTAINTED_off(TARG); /* decontaminate */ + if (lvalue) { /* it's an lvalue! */ + if (SvTYPE(TARG) < SVt_PVLV) { + sv_upgrade(TARG, SVt_PVLV); + sv_magic(TARG, Nullsv, 'v', Nullch, 0); } - else if (size < 8) - retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); - else { - offset >>= 3; - if (size == 8) - retnum = s[offset]; - else if (size == 16) - retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; - else if (size == 32) - retnum = ((unsigned long) s[offset] << 24) + - ((unsigned long) s[offset + 1] << 16) + - (s[offset + 2] << 8) + s[offset+3]; + LvTYPE(TARG) = 'v'; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); } + LvTARGOFF(TARG) = offset; + LvTARGLEN(TARG) = size; } - sv_setuv(TARG, (UV)retnum); + sv_setuv(TARG, do_vecget(src, offset, size)); PUSHs(TARG); RETURN; } @@ -2209,12 +2167,6 @@ PP(pp_rindex) PP(pp_sprintf) { djSP; dMARK; dORIGMARK; dTARGET; -#ifdef USE_LOCALE_NUMERIC - if (PL_op->op_private & OPpLOCALE) - SET_NUMERIC_LOCAL(); - else - SET_NUMERIC_STANDARD(); -#endif do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; @@ -2279,7 +2231,7 @@ PP(pp_crypt) sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else - DIE( + DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif SETs(TARG); @@ -2309,7 +2261,7 @@ PP(pp_ucfirst) tend = uv_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); @@ -2319,26 +2271,27 @@ PP(pp_ucfirst) s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } - s = (U8*)SvPV_force(sv, slen); - if (*s) { - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - *s = toUPPER_LC(*s); + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); + } + s = (U8*)SvPV_force(sv, slen); + if (*s) { + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toUPPER_LC(*s); + } + else + *s = toUPPER(*s); } - else - *s = toUPPER(*s); } - + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2365,7 +2318,7 @@ PP(pp_lcfirst) tend = uv_to_utf8(tmpbuf, uv); - if (!SvPADTMP(sv) || tend - tmpbuf != ulen) { + if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { dTARGET; sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); @@ -2375,27 +2328,28 @@ PP(pp_lcfirst) s = (U8*)SvPV_force(sv, slen); Copy(tmpbuf, s, ulen, U8); } - RETURN; } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } - s = (U8*)SvPV_force(sv, slen); - if (*s) { - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - *s = toLOWER_LC(*s); + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); } - else - *s = toLOWER(*s); + s = (U8*)SvPV_force(sv, slen); + if (*s) { + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + *s = toLOWER_LC(*s); + } + else + *s = toLOWER(*s); + } + SETs(sv); } - - SETs(sv); + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2416,56 +2370,57 @@ PP(pp_uc) if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); - RETURN; - } - - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - (void)SvPOK_only(TARG); - d = (U8*)SvPVX(TARG); - send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); - s += ulen; - } } else { - while (s < send) { - d = uv_to_utf8(d, toUPPER_utf8( s )); - s += UTF8SKIP(s); + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } + } + else { + while (s < send) { + d = uv_to_utf8(d, toUPPER_utf8( s )); + s += UTF8SKIP(s); + } } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); } - *d = '\0'; - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); - SETs(TARG); - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } - - s = (U8*)SvPV_force(sv, len); - if (len) { - register U8 *send = s + len; - - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - for (; s < send; s++) - *s = toUPPER_LC(*s); + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); } - else { - for (; s < send; s++) - *s = toUPPER(*s); + s = (U8*)SvPV_force(sv, len); + if (len) { + register U8 *send = s + len; + + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toUPPER_LC(*s); + } + else { + for (; s < send; s++) + *s = toUPPER(*s); + } } } + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2486,56 +2441,58 @@ PP(pp_lc) if (!len) { sv_setpvn(TARG, "", 0); SETs(TARG); - RETURN; - } - - (void)SvUPGRADE(TARG, SVt_PV); - SvGROW(TARG, (len * 2) + 1); - (void)SvPOK_only(TARG); - d = (U8*)SvPVX(TARG); - send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(TARG); - while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); - s += ulen; - } } else { - while (s < send) { - d = uv_to_utf8(d, toLOWER_utf8(s)); - s += UTF8SKIP(s); + (void)SvUPGRADE(TARG, SVt_PV); + SvGROW(TARG, (len * 2) + 1); + (void)SvPOK_only(TARG); + d = (U8*)SvPVX(TARG); + send = s + len; + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(TARG); + while (s < send) { + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + s += ulen; + } } + else { + while (s < send) { + d = uv_to_utf8(d, toLOWER_utf8(s)); + s += UTF8SKIP(s); + } + } + *d = '\0'; + SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); + SETs(TARG); } - *d = '\0'; - SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); - SETs(TARG); - RETURN; - } - - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); } + else { + if (!SvPADTMP(sv) || SvREADONLY(sv)) { + dTARGET; + sv_setsv(TARG, sv); + sv = TARG; + SETs(sv); + } - s = (U8*)SvPV_force(sv, len); - if (len) { - register U8 *send = s + len; + s = (U8*)SvPV_force(sv, len); + if (len) { + register U8 *send = s + len; - if (PL_op->op_private & OPpLOCALE) { - TAINT; - SvTAINTED_on(sv); - for (; s < send; s++) - *s = toLOWER_LC(*s); - } - else { - for (; s < send; s++) - *s = toLOWER(*s); + if (PL_op->op_private & OPpLOCALE) { + TAINT; + SvTAINTED_on(sv); + for (; s < send; s++) + *s = toLOWER_LC(*s); + } + else { + for (; s < send; s++) + *s = toLOWER(*s); + } } } + if (SvSMAGICAL(sv)) + mg_set(sv); RETURN; } @@ -2583,6 +2540,8 @@ PP(pp_quotemeta) else sv_setpvn(TARG, s, len); SETs(TARG); + if (SvSMAGICAL(TARG)) + mg_set(TARG); RETURN; } @@ -2616,7 +2575,7 @@ PP(pp_aslice) svp = av_fetch(av, elem, lval); if (lval) { if (!svp || *svp == &PL_sv_undef) - DIE(PL_no_aelem, elem); + DIE(aTHX_ PL_no_aelem, elem); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); } @@ -2635,7 +2594,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; dTARGET; + djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2650,12 +2609,13 @@ PP(pp_each) if (entry) { PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { + SV *val; PUTBACK; /* might clobber stack_sp */ - sv_setsv(TARG, realhv ? - hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); + val = realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); SPAGAIN; - PUSHs(TARG); + PUSHs(val); } } else if (gimme == G_SCALAR) @@ -2666,12 +2626,12 @@ PP(pp_each) PP(pp_values) { - return do_kv(ARGS); + return do_kv(); } PP(pp_keys) { - return do_kv(ARGS); + return do_kv(); } PP(pp_delete) @@ -2687,13 +2647,28 @@ PP(pp_delete) U32 hvtype; hv = (HV*)POPs; hvtype = SvTYPE(hv); - while (++MARK <= SP) { - if (hvtype == SVt_PVHV) + if (hvtype == SVt_PVHV) { /* hash element */ + while (++MARK <= SP) { sv = hv_delete_ent(hv, *MARK, discard, 0); - else - DIE("Not a HASH reference"); - *MARK = sv ? sv : &PL_sv_undef; + *MARK = sv ? sv : &PL_sv_undef; + } } + else if (hvtype == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + while (++MARK <= SP) { + sv = av_delete((AV*)hv, SvIV(*MARK), discard); + *MARK = sv ? sv : &PL_sv_undef; + } + } + else { /* pseudo-hash element */ + while (++MARK <= SP) { + sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); + *MARK = sv ? sv : &PL_sv_undef; + } + } + } + else + DIE(aTHX_ "Not a HASH reference"); if (discard) SP = ORIGMARK; else if (gimme == G_SCALAR) { @@ -2707,8 +2682,14 @@ PP(pp_delete) hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) sv = hv_delete_ent(hv, keysv, discard, 0); + else if (SvTYPE(hv) == SVt_PVAV) { + if (PL_op->op_flags & OPf_SPECIAL) + sv = av_delete((AV*)hv, SvIV(keysv), discard); + else + sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); + } else - DIE("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); if (!sv) sv = &PL_sv_undef; if (!discard) @@ -2727,11 +2708,15 @@ PP(pp_exists) RETPUSHYES; } else if (SvTYPE(hv) == SVt_PVAV) { - if (avhv_exists_ent((AV*)hv, tmpsv, 0)) + if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ + if (av_exists((AV*)hv, SvIV(tmpsv))) + RETPUSHYES; + } + else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ RETPUSHYES; } else { - DIE("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); } RETPUSHNO; } @@ -2744,7 +2729,7 @@ PP(pp_hslice) I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) - DIE("Can't localize pseudo-hash element"); + DIE(aTHX_ "Can't localize pseudo-hash element"); if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { @@ -2760,7 +2745,7 @@ PP(pp_hslice) if (lval) { if (!svp || *svp == &PL_sv_undef) { STRLEN n_a; - DIE(PL_no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); @@ -2827,20 +2812,17 @@ PP(pp_lslice) for (lelem = firstlelem; lelem <= lastlelem; lelem++) { ix = SvIVx(*lelem); - if (ix < 0) { + if (ix < 0) ix += max; - if (ix < 0) - *lelem = &PL_sv_undef; - else if (!(*lelem = firstrelem[ix])) - *lelem = &PL_sv_undef; - } - else { + else ix -= arybase; - if (ix >= max || !(*lelem = firstrelem[ix])) + if (ix < 0 || ix >= max) + *lelem = &PL_sv_undef; + else { + is_something_there = TRUE; + if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; } - if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem))) - is_something_there = TRUE; } if (is_something_there) SP = lastlelem; @@ -2870,7 +2852,7 @@ PP(pp_anonhash) if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Odd number of elements in hash assignment"); + Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -2898,7 +2880,7 @@ PP(pp_splice) PUSHMARK(MARK); PUTBACK; ENTER; - perl_call_method("SPLICE",GIMME_V); + call_method("SPLICE",GIMME_V); LEAVE; SPAGAIN; RETURN; @@ -2913,7 +2895,7 @@ PP(pp_splice) else offset -= PL_curcop->cop_arybase; if (offset < 0) - DIE(PL_no_aelem, i); + DIE(aTHX_ PL_no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) { @@ -3092,7 +3074,7 @@ PP(pp_push) PUSHMARK(MARK); PUTBACK; ENTER; - perl_call_method("PUSH",G_SCALAR|G_DISCARD); + call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; } @@ -3148,7 +3130,7 @@ PP(pp_unshift) PUSHMARK(MARK); PUTBACK; ENTER; - perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD); + call_method("UNSHIFT",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; } @@ -3178,6 +3160,7 @@ PP(pp_reverse) *MARK++ = *SP; *SP-- = tmp; } + /* safe as long as stack cannot get extended in the above */ SP = oldsp; } else { @@ -3206,7 +3189,9 @@ PP(pp_reverse) s += UTF8SKIP(s); down = (char*)(s - 1); if (s > send || !((*down & 0xc0) == 0x80)) { - warn("Malformed UTF-8 character"); + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, + "Malformed UTF-8 character"); break; } while (down > up) { @@ -3232,8 +3217,8 @@ PP(pp_reverse) RETURN; } -STATIC SV * -mul128(SV *sv, U8 m) +STATIC SV * +S_mul128(pTHX_ SV *sv, U8 m) { STRLEN len; char *s = SvPV(sv, len); @@ -3276,7 +3261,7 @@ PP(pp_unpack) { djSP; dPOPPOPssrl; - SV **oldsp = SP; + I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; SV *sv; STRLEN llen; @@ -3289,6 +3274,7 @@ PP(pp_unpack) I32 datumtype; register I32 len; register I32 bits; + register char *str; /* These must not be in registers: */ I16 ashort; @@ -3308,8 +3294,9 @@ PP(pp_unpack) double adouble; I32 checksum = 0; register U32 culong; - double cdouble; + NV cdouble; int commas = 0; + int star; #ifdef PERL_NATINT_PACK int natint; /* native integer */ int unatint; /* unsigned native integer */ @@ -3334,6 +3321,11 @@ PP(pp_unpack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -3344,27 +3336,34 @@ PP(pp_unpack) pat++; } else - croak("'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } + star = 0; if (pat >= patend) len = 1; else if (*pat == '*') { len = strend - strbeg; /* long enough */ pat++; + star = 1; } else if (isDIGIT(*pat)) { len = *pat++ - '0'; - while (isDIGIT(*pat)) + while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in unpack overflows"); + } } else len = (datumtype != '@'); + redo_switch: switch(datumtype) { default: - croak("Invalid type in unpack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, + "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') @@ -3377,19 +3376,30 @@ PP(pp_unpack) break; case '@': if (len > strend - strbeg) - DIE("@ outside of string"); + DIE(aTHX_ "@ outside of string"); s = strbeg + len; break; case 'X': if (len > s - strbeg) - DIE("X outside of string"); + DIE(aTHX_ "X outside of string"); s -= len; break; case 'x': if (len > strend - s) - DIE("x outside of string"); + DIE(aTHX_ "x outside of string"); s += len; break; + case '/': + if (start_sp_offset >= SP - PL_stack_base) + DIE(aTHX_ "/ must follow a numeric type"); + datumtype = *pat++; + if (*pat == '*') + pat++; /* ignore '*' for compatibility with pack */ + if (isDIGIT(*pat)) + DIE(aTHX_ "/ cannot take a count" ); + len = POPi; + star = 0; + goto redo_switch; case 'A': case 'Z': case 'a': @@ -3420,7 +3430,7 @@ PP(pp_unpack) break; case 'B': case 'b': - if (pat[-1] == '*' || len > (strend - s) * 8) + if (star || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { if (!PL_bitcount) { @@ -3460,8 +3470,7 @@ PP(pp_unpack) sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'b') { aint = len; for (len = 0; len < aint; len++) { @@ -3469,7 +3478,7 @@ PP(pp_unpack) bits >>= 1; else bits = *s++; - *pat++ = '0' + (bits & 1); + *str++ = '0' + (bits & 1); } } else { @@ -3479,22 +3488,20 @@ PP(pp_unpack) bits <<= 1; else bits = *s++; - *pat++ = '0' + ((bits & 128) != 0); + *str++ = '0' + ((bits & 128) != 0); } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'H': case 'h': - if (pat[-1] == '*' || len > (strend - s) * 2) + if (star || len > (strend - s) * 2) len = (strend - s) * 2; sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'h') { aint = len; for (len = 0; len < aint; len++) { @@ -3502,7 +3509,7 @@ PP(pp_unpack) bits >>= 4; else bits = *s++; - *pat++ = PL_hexdigit[bits & 15]; + *str++ = PL_hexdigit[bits & 15]; } } else { @@ -3512,11 +3519,10 @@ PP(pp_unpack) bits <<= 4; else bits = *s++; - *pat++ = PL_hexdigit[(bits >> 4) & 15]; + *str++ = PL_hexdigit[(bits >> 4) & 15]; } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'c': @@ -3572,7 +3578,7 @@ PP(pp_unpack) auint = utf8_to_uv((U8*)s, &along); s += along; if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } @@ -3600,6 +3606,7 @@ PP(pp_unpack) if (checksum) { #if SHORTSIZE != SIZE16 if (natint) { + short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); @@ -3626,6 +3633,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (natint) { + short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); @@ -3665,6 +3673,7 @@ PP(pp_unpack) if (checksum) { #if SHORTSIZE != SIZE16 if (unatint) { + unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); @@ -3694,6 +3703,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if SHORTSIZE != SIZE16 if (unatint) { + unsigned short aushort; while (len-- > 0) { COPYNN(s, &aushort, sizeof(unsigned short)); s += sizeof(unsigned short); @@ -3732,7 +3742,7 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > 32) - cdouble += (double)aint; + cdouble += (NV)aint; else culong += aint; } @@ -3783,7 +3793,7 @@ PP(pp_unpack) Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } @@ -3818,11 +3828,12 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { + long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3838,7 +3849,7 @@ PP(pp_unpack) #endif s += SIZE32; if (checksum > 32) - cdouble += (double)along; + cdouble += (NV)along; else culong += along; } @@ -3849,6 +3860,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { + long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3888,11 +3900,12 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (unatint) { + unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3912,7 +3925,7 @@ PP(pp_unpack) aulong = vtohl(aulong); #endif if (checksum > 32) - cdouble += (double)aulong; + cdouble += (NV)aulong; else culong += aulong; } @@ -3923,6 +3936,7 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (unatint) { + unsigned long aulong; while (len-- > 0) { COPYNN(s, &aulong, sizeof(unsigned long)); s += sizeof(unsigned long); @@ -3992,7 +4006,7 @@ PP(pp_unpack) char *t; STRLEN n_a; - sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { @@ -4010,7 +4024,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - croak("Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4044,7 +4058,7 @@ PP(pp_unpack) if (aquad >= IV_MIN && aquad <= IV_MAX) sv_setiv(sv, (IV)aquad); else - sv_setnv(sv, (double)aquad); + sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); } break; @@ -4065,7 +4079,7 @@ PP(pp_unpack) if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else - sv_setnv(sv, (double)auquad); + sv_setnv(sv, (NV)auquad); PUSHs(sv_2mortal(sv)); } break; @@ -4090,7 +4104,7 @@ PP(pp_unpack) Copy(s, &afloat, 1, float); s += sizeof(float); sv = NEWSV(47, 0); - sv_setnv(sv, (double)afloat); + sv_setnv(sv, (NV)afloat); PUSHs(sv_2mortal(sv)); } } @@ -4114,7 +4128,7 @@ PP(pp_unpack) Copy(s, &adouble, 1, double); s += sizeof(double); sv = NEWSV(48, 0); - sv_setnv(sv, (double)adouble); + sv_setnv(sv, (NV)adouble); PUSHs(sv_2mortal(sv)); } } @@ -4182,7 +4196,7 @@ PP(pp_unpack) sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || (checksum > 32 && strchr("iIlLNU", datumtype)) ) { - double trouble; + NV trouble; adouble = 1.0; while (checksum >= 16) { @@ -4198,7 +4212,7 @@ PP(pp_unpack) along = (1 << checksum) - 1; while (cdouble < 0.0) cdouble += adouble; - cdouble = modf(cdouble / adouble, &trouble) * adouble; + cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { @@ -4212,13 +4226,13 @@ PP(pp_unpack) checksum = 0; } } - if (SP == oldsp && gimme == G_SCALAR) + if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) PUSHs(&PL_sv_undef); RETURN; } STATIC void -doencodes(register SV *sv, register char *s, register I32 len) +S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) { char hunk[5]; @@ -4246,7 +4260,7 @@ doencodes(register SV *sv, register char *s, register I32 len) } STATIC SV * -is_an_int(char *s, STRLEN l) +S_is_an_int(pTHX_ char *s, STRLEN l) { STRLEN n_a; SV *result = newSVpvn(s, l); @@ -4294,10 +4308,9 @@ is_an_int(char *s, STRLEN l) return (result); } +/* pnum must be '\0' terminated */ STATIC int -div128(SV *pnum, bool *done) - /* must be '\0' terminated */ - +S_div128(pTHX_ SV *pnum, bool *done) { STRLEN len; char *s = SvPV(pnum, len); @@ -4361,13 +4374,19 @@ PP(pp_pack) MARK++; sv_setpvn(cat, "", 0); while (pat < patend) { -#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no) + SV *lengthcode = Nullsv; +#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) datumtype = *pat++ & 0xFF; #ifdef PERL_NATINT_PACK natint = 0; #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -4378,7 +4397,7 @@ PP(pp_pack) pat++; } else - croak("'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; @@ -4386,20 +4405,31 @@ PP(pp_pack) } else if (isDIGIT(*pat)) { len = *pat++ - '0'; - while (isDIGIT(*pat)) + while (isDIGIT(*pat)) { len = (len * 10) + (*pat++ - '0'); + if (len < 0) + DIE(aTHX_ "Repeat count in pack overflows"); + } } else len = 1; + if (*pat == '/') { + ++pat; + if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*') + DIE(aTHX_ "/ must be followed by a*, A* or Z*"); + lengthcode = sv_2mortal(newSViv(sv_len(items > 0 + ? *MARK : &PL_sv_no))); + } switch(datumtype) { default: - croak("Invalid type in pack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ if (commas++ == 0 && ckWARN(WARN_UNSAFE)) - warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, + "Invalid type in pack: '%c'", (int)datumtype); break; case '%': - DIE("%% may only be used in unpack"); + DIE(aTHX_ "%% may only be used in unpack"); case '@': len -= SvCUR(cat); if (len > 0) @@ -4411,7 +4441,7 @@ PP(pp_pack) case 'X': shrink: if (SvCUR(cat) < len) - DIE("X outside of string"); + DIE(aTHX_ "X outside of string"); SvCUR(cat) -= len; *SvEND(cat) = '\0'; break; @@ -4428,10 +4458,16 @@ PP(pp_pack) case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); - if (pat[-1] == '*') + if (pat[-1] == '*') { len = fromlen; - if (fromlen > len) + if (datumtype == 'Z') + ++len; + } + if (fromlen >= len) { sv_catpvn(cat, aptr, len); + if (datumtype == 'Z') + *(SvEND(cat)-1) = '\0'; + } else { sv_catpvn(cat, aptr, fromlen); len -= fromlen; @@ -4454,15 +4490,14 @@ PP(pp_pack) case 'B': case 'b': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+7)/8; SvGROW(cat, SvCUR(cat) + 1); @@ -4473,7 +4508,7 @@ PP(pp_pack) items = 0; if (datumtype == 'B') { for (len = 0; len++ < aint;) { - items |= *pat++ & 1; + items |= *str++ & 1; if (len & 7) items <<= 1; else { @@ -4484,7 +4519,7 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (*pat++ & 1) + if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; @@ -4501,26 +4536,24 @@ PP(pp_pack) items >>= 7 - (aint & 7); *aptr++ = items & 0xff; } - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; case 'H': case 'h': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+1)/2; SvGROW(cat, SvCUR(cat) + 1); @@ -4531,10 +4564,10 @@ PP(pp_pack) items = 0; if (datumtype == 'H') { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= ((*pat++ & 15) + 9) & 15; + if (isALPHA(*str)) + items |= ((*str++ & 15) + 9) & 15; else - items |= *pat++ & 15; + items |= *str++ & 15; if (len & 1) items <<= 4; else { @@ -4545,10 +4578,10 @@ PP(pp_pack) } else { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= (((*pat++ & 15) + 9) & 15) << 4; + if (isALPHA(*str)) + items |= (((*str++ & 15) + 9) & 15) << 4; else - items |= (*pat++ & 15) << 4; + items |= (*str++ & 15) << 4; if (len & 1) items >>= 4; else { @@ -4559,11 +4592,10 @@ PP(pp_pack) } if (aint & 1) *aptr++ = items & 0xff; - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; @@ -4650,6 +4682,8 @@ PP(pp_pack) case 's': #if SHORTSIZE != SIZE16 if (natint) { + short ashort; + while (len-- > 0) { fromstr = NEXTFROM; ashort = SvIV(fromstr); @@ -4676,10 +4710,10 @@ PP(pp_pack) case 'w': while (len-- > 0) { fromstr = NEXTFROM; - adouble = floor(SvNV(fromstr)); + adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) - croak("Cannot compress negative numbers"); + DIE(aTHX_ "Cannot compress negative numbers"); if ( #ifdef BW_BITS @@ -4695,7 +4729,7 @@ PP(pp_pack) { char buf[1 + sizeof(UV)]; char *in = buf + sizeof(buf); - UV auv = U_V(adouble);; + UV auv = U_V(adouble); do { *--in = (auv & 0x7f) | 0x80; @@ -4713,7 +4747,7 @@ PP(pp_pack) /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - croak("can compress only unsigned integer"); + DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; @@ -4733,14 +4767,14 @@ PP(pp_pack) double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - croak ("Cannot compress integer"); + DIE(aTHX_ "Cannot compress integer"); adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else - croak("Cannot compress non integer"); + DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': @@ -4773,6 +4807,8 @@ PP(pp_pack) case 'L': #if LONGSIZE != SIZE32 if (natint) { + unsigned long aulong; + while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); @@ -4792,6 +4828,8 @@ PP(pp_pack) case 'l': #if LONGSIZE != SIZE32 if (natint) { + long along; + while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); @@ -4812,7 +4850,7 @@ PP(pp_pack) case 'Q': while (len-- > 0) { fromstr = NEXTFROM; - auquad = (Uquad_t)SvIV(fromstr); + auquad = (Uquad_t)SvUV(fromstr); sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; @@ -4823,7 +4861,7 @@ PP(pp_pack) sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; -#endif /* HAS_QUAD */ +#endif case 'P': len = 1; /* assume SV is correct length */ /* FALL THROUGH */ @@ -4839,9 +4877,13 @@ PP(pp_pack) * of pack() (and all copies of the result) are * gone. */ - if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) - warner(WARN_UNSAFE, + if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) + || (SvPADTMP(fromstr) + && !SvREADONLY(fromstr)))) + { + Perl_warner(aTHX_ WARN_UNSAFE, "Attempt to pack pointer to temporary value"); + } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); else @@ -4912,14 +4954,19 @@ PP(pp_split) pm = (PMOP*)POPs; #endif if (!pm || !s) - DIE("panic: do_split"); + DIE(aTHX_ "panic: do_split"); rx = pm->op_pmregexp; TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); - if (pm->op_pmreplroot) + if (pm->op_pmreplroot) { +#ifdef USE_ITHREADS + ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); +#else ary = GvAVn((GV*)pm->op_pmreplroot); +#endif + } else if (gimme != G_ARRAY) #ifdef USE_THREADS ary = (AV*)PL_curpad[0]; @@ -4941,6 +4988,7 @@ PP(pp_split) else { if (!AvREAL(ary)) { AvREAL_on(ary); + AvREIFY_off(ary); for (i = AvFILLp(ary); i >= 0; i--) AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ } @@ -5006,15 +5054,19 @@ PP(pp_split) s = m; } } - else if (rx->check_substr && !rx->nparens + else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens && (rx->reganch & ROPT_CHECK_ALL) && !(rx->reganch & ROPT_ANCH)) { - i = SvCUR(rx->check_substr); - if (i == 1 && !SvTAIL(rx->check_substr)) { - i = *SvPVX(rx->check_substr); + int tail = (rx->reganch & RE_INTUIT_TAIL); + SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); + char c; + + len = rx->minlen; + if (len == 1 && !tail) { + c = *SvPV(csv,len); while (--limit) { /*SUPPRESS 530*/ - for (m = s; m < strend && *m != i; m++) ; + for (m = s; m < strend && *m != c; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); @@ -5028,8 +5080,8 @@ PP(pp_split) else { #ifndef lint while (s < strend && --limit && - (m=fbm_instr((unsigned char*)s, (unsigned char*)strend, - rx->check_substr, 0)) ) + (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, + csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) #endif { dstr = NEWSV(31, m-s); @@ -5037,25 +5089,28 @@ PP(pp_split) if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); - s = m + i; + s = m + len; /* Fake \n at the end */ } } } else { maxiters += (strend - s) * rx->nparens; - while (s < strend && --limit && - CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0)) + 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)) { TAINT_IF(RX_MATCH_TAINTED(rx)); - if (rx->subbase - && rx->subbase != orig) { + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - orig = rx->subbase; + orig = rx->subbeg; s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0]; + m = rx->startp[0] + orig; dstr = NEWSV(32, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) @@ -5063,8 +5118,8 @@ PP(pp_split) XPUSHs(dstr); if (rx->nparens) { for (i = 1; i <= rx->nparens; i++) { - s = rx->startp[i]; - m = rx->endp[i]; + s = rx->startp[i] + orig; + m = rx->endp[i] + orig; if (m && s) { dstr = NEWSV(33, m-s); sv_setpvn(dstr, s, m-s); @@ -5076,14 +5131,14 @@ PP(pp_split) XPUSHs(dstr); } } - s = rx->endp[0]; + s = rx->endp[0] + orig; } } LEAVE_SCOPE(oldsave); iters = (SP - PL_stack_base) - base; if (iters > maxiters) - DIE("Split loop"); + DIE(aTHX_ "Split loop"); /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { @@ -5117,7 +5172,7 @@ PP(pp_split) else { PUTBACK; ENTER; - perl_call_method("PUSH",G_SCALAR|G_DISCARD); + call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; if (gimme == G_ARRAY) { @@ -5145,20 +5200,20 @@ PP(pp_split) #ifdef USE_THREADS void -unlock_condpair(void *svv) +Perl_unlock_condpair(pTHX_ void *svv) { dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) - croak("panic: unlock_condpair unlocking non-mutex"); + Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) - croak("panic: unlock_condpair unlocking mutex that we don't own"); + Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", - (unsigned long)thr, (unsigned long)svv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(svv));) MUTEX_UNLOCK(MgMUTEXP(mg)); } #endif /* USE_THREADS */ @@ -5182,10 +5237,10 @@ PP(pp_lock) while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", - (unsigned long)thr, (unsigned long)sv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV @@ -5207,6 +5262,6 @@ PP(pp_threadsv) PUSHs(THREADSV(PL_op->op_targ)); RETURN; #else - DIE("tried to access per-thread data in non-threaded perl"); + DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); #endif /* USE_THREADS */ }