X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=2948d3a89ea795b084a3ada2077be54fa9af9ab9;hb=6c1372ede9e641f6d25ae7a5966416ab272c51d3;hp=3f21cf2909e900ffbf8db976c53c75d6ac22ec91;hpb=0453d815b8a74697ff1e5451c27aba2fe537b8e0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index 3f21cf2..2948d3a 100644 --- a/pp.c +++ b/pp.c @@ -406,6 +406,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; @@ -467,7 +469,7 @@ PP(pp_prototype) goto set; else { /* None such */ nonesuch: - Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6); + DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } @@ -528,6 +530,12 @@ S_refto(pTHX_ 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 { @@ -863,7 +871,7 @@ PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -880,7 +888,7 @@ PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ PL_no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -900,8 +908,8 @@ PP(pp_postinc) PP(pp_postdec) { djSP; dTARGET; - if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - Perl_croak(aTHX_ 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) @@ -1776,9 +1784,9 @@ S_seed(pTHX) # endif #endif u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)PL_stack_sp; + 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; } @@ -1885,14 +1893,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; @@ -1908,7 +1916,7 @@ PP(pp_oct) value = scan_bin(++tmps, 99, &argtype); else value = scan_oct(tmps, 99, &argtype); - XPUSHu(value); + XPUSHn(value); RETURN; } @@ -2052,74 +2060,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; } @@ -2631,7 +2589,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; dTARGET; + djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2646,12 +2604,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) @@ -3198,9 +3157,10 @@ PP(pp_reverse) up = (char*)s; s += UTF8SKIP(s); down = (char*)(s - 1); - if ((s > send || !((*down & 0xc0) == 0x80)) && - ckWARN_d(WARN_UTF8)) { - Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); + if (s > send || !((*down & 0xc0) == 0x80)) { + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, + "Malformed UTF-8 character"); break; } while (down > up) { @@ -3328,6 +3288,11 @@ PP(pp_unpack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -3338,7 +3303,7 @@ PP(pp_unpack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (pat >= patend) len = 1; @@ -3348,17 +3313,21 @@ PP(pp_unpack) } 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 != '@'); switch(datumtype) { default: - Perl_croak(aTHX_ "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)) - Perl_warner(aTHX_ 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') @@ -3384,6 +3353,18 @@ PP(pp_unpack) DIE(aTHX_ "x outside of string"); s += len; break; + case '/': + if (oldsp >= SP) + DIE(aTHX_ "/ must follow a numeric type"); + if (*pat != 'a' && *pat != 'A' && *pat != 'Z') + DIE(aTHX_ "/ must be followed by a, A or Z"); + datumtype = *pat++; + if (*pat == '*') + pat++; /* ignore '*' for compatibility with pack */ + if (isDIGIT(*pat)) + DIE(aTHX_ "/ cannot take a count" ); + len = POPi; + /* drop through */ case 'A': case 'Z': case 'a': @@ -3594,6 +3575,7 @@ PP(pp_unpack) if (checksum) { #if SHORTSIZE != SIZE16 if (natint) { + short ashort; while (len-- > 0) { COPYNN(s, &ashort, sizeof(short)); s += sizeof(short); @@ -3620,6 +3602,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); @@ -3659,6 +3642,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); @@ -3688,6 +3672,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); @@ -3812,6 +3797,7 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { + long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3843,6 +3829,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); @@ -3882,6 +3869,7 @@ 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); @@ -3917,6 +3905,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); @@ -4004,7 +3993,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - Perl_croak(aTHX_ "Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4354,13 +4343,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"; @@ -4371,7 +4366,7 @@ PP(pp_pack) pat++; } else - Perl_croak(aTHX_ "'!' allowed only after types %s", natstr); + DIE(aTHX_ "'!' allowed only after types %s", natstr); } if (*pat == '*') { len = strchr("@Xxu", datumtype) ? 0 : items; @@ -4379,17 +4374,28 @@ 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: - Perl_croak(aTHX_ "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)) - Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); + Perl_warner(aTHX_ WARN_UNSAFE, + "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE(aTHX_ "%% may only be used in unpack"); @@ -4643,6 +4649,8 @@ PP(pp_pack) case 's': #if SHORTSIZE != SIZE16 if (natint) { + short ashort; + while (len-- > 0) { fromstr = NEXTFROM; ashort = SvIV(fromstr); @@ -4672,7 +4680,7 @@ PP(pp_pack) adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) - Perl_croak(aTHX_ "Cannot compress negative numbers"); + DIE(aTHX_ "Cannot compress negative numbers"); if ( #ifdef BW_BITS @@ -4706,7 +4714,7 @@ PP(pp_pack) /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "can compress only unsigned integer"); + DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; @@ -4726,14 +4734,14 @@ PP(pp_pack) double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - Perl_croak(aTHX_ "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 - Perl_croak(aTHX_ "Cannot compress non integer"); + DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': @@ -4766,6 +4774,8 @@ PP(pp_pack) case 'L': #if LONGSIZE != SIZE32 if (natint) { + unsigned long aulong; + while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); @@ -4785,6 +4795,8 @@ PP(pp_pack) case 'l': #if LONGSIZE != SIZE32 if (natint) { + long along; + while (len-- > 0) { fromstr = NEXTFROM; along = SvIV(fromstr); @@ -4805,7 +4817,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; @@ -4934,6 +4946,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 */ } @@ -5185,7 +5198,7 @@ PP(pp_lock) DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(Perl_unlock_condpair, sv); + SAVEDESTRUCTOR(Perl_unlock_condpair, sv); } #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV