X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp.c;h=6b45946db4350a035c81e427e366a28a62085a5a;hb=7ec2cea42ff48a380e66445f3c1f56b9ff25c203;hp=c659e33ec4729cd99366d10ac733ccd45882ac14;hpb=bf9315bb7b3bbee98610905699a0af5e65da9269;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp.c b/pp.c index c659e33..6b45946 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) @@ -901,7 +909,7 @@ PP(pp_postdec) { 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_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; } @@ -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; } @@ -3330,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"; @@ -3340,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; @@ -3350,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') @@ -3386,16 +3353,16 @@ PP(pp_unpack) DIE(aTHX_ "x outside of string"); s += len; break; - case '#': + case '/': if (oldsp >= SP) - DIE(aTHX_ "# must follow a numeric type"); + DIE(aTHX_ "/ must follow a numeric type"); if (*pat != 'a' && *pat != 'A' && *pat != 'Z') - DIE(aTHX_ "# must be followed by a, A or 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" ); + DIE(aTHX_ "/ cannot take a count" ); len = POPi; /* drop through */ case 'A': @@ -4026,7 +3993,7 @@ PP(pp_unpack) } } if ((s >= strend) && bytes) - Perl_croak(aTHX_ "Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': @@ -4384,6 +4351,11 @@ PP(pp_pack) #endif if (isSPACE(datumtype)) continue; + if (datumtype == '#') { + while (pat < patend && *pat != '\n') + pat++; + continue; + } if (*pat == '!') { char *natstr = "sSiIlL"; @@ -4394,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; @@ -4402,21 +4374,24 @@ 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 == '#') { + if (*pat == '/') { ++pat; if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*') - DIE(aTHX_ "# must be followed by a*, A* or Z*"); + 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, @@ -4705,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 @@ -4739,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; @@ -4759,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': @@ -4971,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 */ } @@ -5194,7 +5170,7 @@ Perl_unlock_condpair(pTHX_ void *svv) 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", + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: unlock 0x%lx\n", (unsigned long)thr, (unsigned long)svv);) MUTEX_UNLOCK(MgMUTEXP(mg)); } @@ -5219,7 +5195,7 @@ 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", + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%lx: pp_lock lock 0x%lx\n", (unsigned long)thr, (unsigned long)sv);) MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR(Perl_unlock_condpair, sv);