This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
More descriptive names for operators.
[perl5.git] / pp.c
diff --git a/pp.c b/pp.c
index c7fd585..07bb33d 100644 (file)
--- 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))
+           Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
     }
     else
        cv = (CV*)&PL_sv_undef;
@@ -900,7 +902,7 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     djSP; dTARGET;
-    if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+    if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
        Perl_croak(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
@@ -1776,9 +1778,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 +1887,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 +1910,7 @@ PP(pp_oct)
        value = scan_bin(++tmps, 99, &argtype);
     else
        value = scan_oct(tmps, 99, &argtype);
-    XPUSHu(value);
+    XPUSHn(value);
     RETURN;
 }
 
@@ -2052,74 +2054,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;
 }
@@ -3350,8 +3302,11 @@ PP(pp_unpack)
        }
        else if (isDIGIT(*pat)) {
            len = *pat++ - '0';
-           while (isDIGIT(*pat))
+           while (isDIGIT(*pat)) {
                len = (len * 10) + (*pat++ - '0');
+               if (len < 0)
+                   Perl_croak(aTHX_ "Repeat count in unpack overflows");
+           }
        }
        else
            len = (datumtype != '@');
@@ -3386,6 +3341,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':
@@ -3596,6 +3563,7 @@ PP(pp_unpack)
            if (checksum) {
 #if SHORTSIZE != SIZE16
                if (natint) {
+                   short ashort;
                    while (len-- > 0) {
                        COPYNN(s, &ashort, sizeof(short));
                        s += sizeof(short);
@@ -3622,6 +3590,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);
@@ -3661,6 +3630,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);
@@ -3690,6 +3660,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);
@@ -3814,6 +3785,7 @@ PP(pp_unpack)
            if (checksum) {
 #if LONGSIZE != SIZE32
                if (natint) {
+                   long along;
                    while (len-- > 0) {
                        COPYNN(s, &along, sizeof(long));
                        s += sizeof(long);
@@ -3845,6 +3817,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);
@@ -3884,6 +3857,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);
@@ -3919,6 +3893,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);
@@ -4356,7 +4331,8 @@ 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;
@@ -4381,17 +4357,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)
+                   Perl_croak(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);
        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");
@@ -4645,6 +4632,8 @@ PP(pp_pack)
        case 's':
 #if SHORTSIZE != SIZE16
            if (natint) {
+               short ashort;
+
                while (len-- > 0) {
                    fromstr = NEXTFROM;
                    ashort = SvIV(fromstr);
@@ -4768,6 +4757,8 @@ PP(pp_pack)
        case 'L':
 #if LONGSIZE != SIZE32
            if (natint) {
+               unsigned long aulong;
+
                while (len-- > 0) {
                    fromstr = NEXTFROM;
                    aulong = SvUV(fromstr);
@@ -4787,6 +4778,8 @@ PP(pp_pack)
        case 'l':
 #if LONGSIZE != SIZE32
            if (natint) {
+               long along;
+
                while (len-- > 0) {
                    fromstr = NEXTFROM;
                    along = SvIV(fromstr);
@@ -4807,7 +4800,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;
@@ -4936,6 +4929,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 */
            }
Unnamed repository; edit this file 'description' to name the repository.