Even more :utf8 socket testing, now in both directions.

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

diff --git a/op.c b/op.c
index f3e616f..947b5f3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -194,7 +194,7 @@ Perl_allocmy(pTHX_ char *name)
 
     /* check for duplicate declaration */
     pad_check_dup(name,
-               PL_in_my == KEY_our,
+               (bool)(PL_in_my == KEY_our),
                (PL_curstash ? PL_curstash : PL_defstash)
     );
 
@@ -2009,6 +2009,8 @@ Perl_gen_constant_list(pTHX_ register OP *o)
 
     o->op_type = OP_RV2AV;
     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+    o->op_flags &= ~OPf_REF;   /* treat \(1..2) like an ordinary list */
+    o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
     o->op_seq = 0;             /* needs to be revisited in peep() */
     curop = ((UNOP*)o)->op_first;
     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
@@ -2292,13 +2294,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        U8* tend = t + tlen;
        U8* rend = r + rlen;
        STRLEN ulen;
-       U32 tfirst = 1;
-       U32 tlast = 0;
-       I32 tdiff;
-       U32 rfirst = 1;
-       U32 rlast = 0;
-       I32 rdiff;
-       I32 diff;
+       UV tfirst = 1;
+       UV tlast = 0;
+       IV tdiff;
+       UV rfirst = 1;
+       UV rlast = 0;
+       IV rdiff;
+       IV diff;
        I32 none = 0;
        U32 max = 0;
        I32 bits;
@@ -2653,6 +2655,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
                           : OPf_KIDS);
        rcop->op_private = 1;
        rcop->op_other = o;
+       /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
+       PL_cv_has_eval = 1;
 
        /* establish postfix order */
        if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
@@ -3618,11 +3622,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
        if (!next)
            next = unstack;
        cont = append_elem(OP_LINESEQ, cont, unstack);
-       if ((line_t)whileline != NOLINE) {
-           PL_copline = (line_t)whileline;
-           cont = append_elem(OP_LINESEQ, cont,
-                              newSTATEOP(0, Nullch, Nullop));
-       }
     }
 
     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
@@ -3675,13 +3674,16 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
     OP *wop;
     PADOFFSET padoff = 0;
     I32 iterflags = 0;
+    I32 iterpflags = 0;
 
     if (sv) {
        if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
+           iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
            sv->op_type = OP_RV2GV;
            sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
        }
        else if (sv->op_type == OP_PADSV) { /* private variable */
+           iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
            padoff = sv->op_targ;
            sv->op_targ = 0;
            op_free(sv);
@@ -3740,6 +3742,9 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
                               append_elem(OP_LIST, expr, scalar(sv))));
     assert(!loop->op_next);
+    /* for my  $x () sets OPpLVAL_INTRO;
+     * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
+    loop->op_private = (U8)iterpflags;
 #ifdef PL_OP_SLAB_ALLOC
     {
        LOOP *tmp;
@@ -3885,6 +3890,26 @@ Perl_cv_const_sv(pTHX_ CV *cv)
     return (SV*)CvXSUBANY(cv).any_ptr;
 }
 
+/* op_const_sv:  examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ *     look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ *     examine the clone prototype, and if contains only a single
+ *     OP_CONST referencing a pad const, or a single PADSV referencing
+ *     an outer lexical, return a non-zero value to indicate the CV is
+ *     a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ *     We have just cloned an anon prototype that was marked as a const
+ *     candidiate. Try to grab the current value, and in the case of
+ *     PADSV, ignore it if it has multiple references. Return the value.
+ */
+
 SV *
 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 {
@@ -3913,26 +3938,31 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
            return Nullsv;
        if (type == OP_CONST && cSVOPo->op_sv)
            sv = cSVOPo->op_sv;
-       else if ((type == OP_PADSV || type == OP_CONST) && cv) {
+       else if (cv && type == OP_CONST) {
            sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
            if (!sv)
                return Nullsv;
-           if (CvCONST(cv)) {
-               /* We get here only from cv_clone2() while creating a closure.
-                  Copy the const value here instead of in cv_clone2 so that
-                  SvREADONLY_on doesn't lead to problems when leaving
-                  scope.
-               */
+       }
+       else if (cv && type == OP_PADSV) {
+           if (CvCONST(cv)) { /* newly cloned anon */
+               sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+               /* the candidate should have 1 ref from this pad and 1 ref
+                * from the parent */
+               if (!sv || SvREFCNT(sv) != 2)
+                   return Nullsv;
                sv = newSVsv(sv);
+               SvREADONLY_on(sv);
+               return sv;
+           }
+           else {
+               if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+                   sv = &PL_sv_undef; /* an arbitrary non-null value */
            }
-           if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
-               return Nullsv;
        }
-       else
+       else {
            return Nullsv;
+       }
     }
-    if (sv)
-       SvREADONLY_on(sv);
     return sv;
 }
 
@@ -4134,6 +4164,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
        /* ... before we throw it away */
        SvREFCNT_dec(PL_compcv);
+       PL_compcv = cv;
        if (PERLDB_INTER)/* Advice debugger on the new sub. */
          ++PL_sub_generation;
     }
@@ -4670,8 +4701,9 @@ Perl_ck_bitop(pTHX_ OP *o)
 OP *
 Perl_ck_concat(pTHX_ OP *o)
 {
-    if (cUNOPo->op_first->op_type == OP_CONCAT)
-       o->op_flags |= OPf_STACKED;
+    OP *kid = cUNOPo->op_first;
+    if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
+        o->op_flags |= OPf_STACKED;
     return o;
 }
 
@@ -4783,8 +4815,10 @@ Perl_ck_eval(pTHX_ OP *o)
            enter->op_other = o;
            return o;
        }
-       else
+       else {
            scalar((OP*)kid);
+           PL_cv_has_eval = 1;
+       }
     }
     else {
        op_free(o);