buncha MacPerl patches for bleadperl

[p5sagit/p5-mst-13.2.git] / op.c

diff --git a/op.c b/op.c
index dc51040..366b183 100644 (file)
--- a/op.c
+++ b/op.c
@@ -55,7 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz)
      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 
 #define PAD_MAX 999999999
-#define RETVAL_MAX ( PERL_INT_MAX / 2 )
+#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 
 STATIC char*
 S_gv_ename(pTHX_ GV *gv)
@@ -1416,7 +1416,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
        }
        else {                          /* lvalue subroutine call */
            o->op_private |= OPpLVAL_INTRO;
-           PL_modcount = RETVAL_MAX;
+           PL_modcount = RETURN_UNLIMITED_NUMBER;
            if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
                /* Backward compatibility mode: */
                o->op_private |= OPpENTERSUB_INARGS;
@@ -1551,7 +1551,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
        if (!type && cUNOPo->op_first->op_type != OP_GV)
            Perl_croak(aTHX_ "Can't localize through a reference");
        if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
-           PL_modcount = RETVAL_MAX;
+           PL_modcount = RETURN_UNLIMITED_NUMBER;
            return o;           /* Treat \(@foo) like ordinary list. */
        }
        /* FALL THROUGH */
@@ -1568,9 +1568,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_AASSIGN:
     case OP_NEXTSTATE:
     case OP_DBSTATE:
-    case OP_REFGEN:
     case OP_CHOMP:
-       PL_modcount = RETVAL_MAX;
+       PL_modcount = RETURN_UNLIMITED_NUMBER;
        break;
     case OP_RV2SV:
        if (!type && cUNOPo->op_first->op_type != OP_GV)
@@ -1589,7 +1588,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 
     case OP_PADAV:
     case OP_PADHV:
-       PL_modcount = RETVAL_MAX;
+       PL_modcount = RETURN_UNLIMITED_NUMBER;
        if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
            return o;           /* Treat \(@foo) like ordinary list. */
        if (scalar_mod_type(o, type))
@@ -1957,6 +1956,16 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
     } else if (type == OP_RV2SV ||     /* "our" declaration */
               type == OP_RV2AV ||
               type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+        if (attrs) {
+            GV *gv = cGVOPx_gv(cUNOPo->op_first);
+            PL_in_my = FALSE;
+            PL_in_my_stash = Nullhv;
+            apply_attrs(GvSTASH(gv),
+                        (type == OP_RV2SV ? GvSV(gv) :
+                         type == OP_RV2AV ? (SV*)GvAV(gv) :
+                         type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+                        attrs);
+        }
        o->op_private |= OPpOUR_INTRO;
        return o;
     } else if (type != OP_PADSV &&
@@ -2410,13 +2419,6 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
     if (o->op_type != type)
        return o;
 
-    if (cLISTOPo->op_children < 7) {
-       /* XXX do we really need to do this if we're done appending?? */
-       for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
-           last = kid;
-       cLISTOPo->op_last = last;       /* in case check substituted last arg */
-    }
-
     return fold_constants(o);
 }
 
@@ -2444,7 +2446,6 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
        ((LISTOP*)first)->op_first = last;
     }
     ((LISTOP*)first)->op_last = last;
-    ((LISTOP*)first)->op_children++;
     return first;
 }
 
@@ -2465,9 +2466,7 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
 
     first->op_last->op_sibling = last->op_first;
     first->op_last = last->op_last;
-    first->op_children += last->op_children;
-    if (first->op_children)
-       first->op_flags |= OPf_KIDS;
+    first->op_flags |= (last->op_flags & OPf_KIDS);
 
 #ifdef PL_OP_SLAB_ALLOC
 #else
@@ -2500,7 +2499,7 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
            first->op_sibling = ((LISTOP*)last)->op_first;
            ((LISTOP*)last)->op_first = first;
        }
-       ((LISTOP*)last)->op_children++;
+       last->op_flags |= OPf_KIDS;
        return last;
     }
 
@@ -2533,7 +2532,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
 
     listop->op_type = type;
     listop->op_ppaddr = PL_ppaddr[type];
-    listop->op_children = (first != 0) + (last != 0);
+    if (first || last)
+       flags |= OPf_KIDS;
     listop->op_flags = flags;
 
     if (!last && first)
@@ -2553,8 +2553,6 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
        if (!last)
            listop->op_last = pushop;
     }
-    else if (listop->op_children)
-       listop->op_flags |= OPf_KIDS;
 
     return (OP*)listop;
 }
@@ -2705,7 +2703,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            while (t < tend) {
                cp[i++] = t;
                t += UTF8SKIP(t);
-               if (*t == 0xff) {
+               if (t < tend && *t == 0xff) {
                    t++;
                    t += UTF8SKIP(t);
                }
@@ -2713,7 +2711,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            qsort(cp, i, sizeof(U8*), utf8compare);
            for (j = 0; j < i; j++) {
                U8 *s = cp[j];
-               I32 cur = j < i ? cp[j+1] - s : tend - s;
+               I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
                UV  val = utf8_to_uv(s, cur, &ulen, 0);
                s += ulen;
                diff = val - nextmin;
@@ -2726,7 +2724,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                        sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
                    }
                }
-               if (*s == 0xff)
+               if (s < tend && *s == 0xff)
                    val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
                if (val >= nextmin)
                    nextmin = val + 1;
@@ -2739,6 +2737,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            t = (U8*)SvPVX(transv);
            tlen = SvCUR(transv);
            tend = t + tlen;
+           Safefree(cp);
        }
        else if (!rlen && !del) {
            r = t; rlen = tlen; rend = tend;
@@ -2831,6 +2830,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        else
            bits = 8;
 
+       Safefree(cPVOPo->op_pv);
        cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
        SvREFCNT_dec(listsv);
        if (transv)
@@ -3521,7 +3521,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                    }
                }
                else {
-                   if (PL_modcount < RETVAL_MAX &&
+                   if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
                      ((LISTOP*)right)->op_last->op_type == OP_CONST)
                    {
                        SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
@@ -4558,6 +4558,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
 
+#ifdef GV_SHARED_CHECK
+    if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
+        Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
+    }
+#endif
+
     if (!block || !ps || *ps || attrs)
        const_sv = Nullsv;
     else
@@ -4565,6 +4571,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     if (cv) {
         bool exists = CvROOT(cv) || CvXSUB(cv);
+
+#ifdef GV_SHARED_CHECK
+        if (exists && GvSHARED(gv)) {
+            Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
+        }
+#endif
+
         /* if the subroutine doesn't exist and wasn't pre-declared
          * with a prototype, assume it will be AUTOLOADed,
          * skipping the prototype check
@@ -5016,6 +5029,11 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     else
        name = "STDOUT";
     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
+#ifdef GV_SHARED_CHECK
+    if (GvSHARED(gv)) {
+        Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
+    }
+#endif
     GvMULTI_on(gv);
     if ((cv = GvFORM(gv))) {
        if (ckWARN(WARN_REDEFINE)) {
@@ -6309,7 +6327,6 @@ S_simplify_sort(pTHX_ OP *o)
     kid = cLISTOPo->op_first->op_sibling;
     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
     op_free(kid);                                    /* then delete it */
-    cLISTOPo->op_children--;
 }
 
 OP *