change#1614 merely disabled earlier fix (doh!); undo it and properly

fixup the cop_seq value that must be seen by lexical lookups that
emanate within eval''

p4raw-link: @1614 on //depot/perl: bd28dd3ca083953e5682058b02b9529902e14ca9

p4raw-id: //depot/perl@1944

diff --git a/cop.h b/cop.h
index f15b1e1..98ae91f 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -199,7 +199,7 @@ struct block {
        pm               = cx->blk_oldpm,                               \
        gimme            = cx->blk_gimme;                               \
        DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n",         \
-                   (long)cxstack_ix+1,block_type[cx->cx_type]); )
+                   (long)cxstack_ix+1,block_type[CxTYPE(cx)]); )
 
 /* Continue a block elsewhere (NEXT and REDO). */
 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],                       \
@@ -262,12 +262,14 @@ struct subst {
        rxres_free(&cx->sb_rxres)
 
 struct context {
-    I32                cx_type;        /* what kind of context this is */
+    U32                cx_type;        /* what kind of context this is */
     union {
        struct block    cx_blk;
        struct subst    cx_subst;
     } cx_u;
 };
+
+#define CXTYPEMASK     0xff
 #define CXt_NULL       0
 #define CXt_SUB                1
 #define CXt_EVAL       2
@@ -275,6 +277,12 @@ struct context {
 #define CXt_SUBST      4
 #define CXt_BLOCK      5
 
+/* private flags for CXt_EVAL */
+#define CXp_REAL       0x00000100      /* truly eval'', not a lookalike */
+
+#define CxTYPE(c)      ((c)->cx_type & CXTYPEMASK)
+#define CxREALEVAL(c)  (((c)->cx_type & (CXt_EVAL|CXp_REAL)) == (CXt_EVAL|CXp_REAL))
+
 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 
 /* "gimme" values */

diff --git a/op.c b/op.c
index b2d6f77..d673fad 100644 (file)
--- a/op.c
+++ b/op.c
@@ -230,14 +230,18 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
                            CV *bcv;
                            for (bcv = startcv;
                                 bcv && bcv != cv && !CvCLONE(bcv);
-                                bcv = CvOUTSIDE(bcv)) {
+                                bcv = CvOUTSIDE(bcv))
+                           {
                                if (CvANON(bcv))
                                    CvCLONE_on(bcv);
                                else {
-                                   if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv))
+                                   if (ckWARN(WARN_CLOSURE)
+                                       && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
+                                   {
                                        warner(WARN_CLOSURE,
                                          "Variable \"%s\" may be unavailable",
                                             name);
+                                   }
                                    break;
                                }
                            }
@@ -262,7 +266,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 
     for (i = cx_ix; i >= 0; i--) {
        cx = &cxstack[i];
-       switch (cx->cx_type) {
+       switch (CxTYPE(cx)) {
        default:
            if (i == 0 && saweval) {
                seq = cxstack[saweval].blk_oldcop->cop_seq;
@@ -272,7 +276,8 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
        case CXt_EVAL:
            switch (cx->blk_eval.old_op_type) {
            case OP_ENTEREVAL:
-               saweval = i;
+               if (CxREALEVAL(cx))
+                   saweval = i;
                break;
            case OP_REQUIRE:
                /* require must have its own scope */
@@ -304,6 +309,7 @@ pad_findmy(char *name)
     SV *sv;
     SV **svp = AvARRAY(PL_comppad_name);
     U32 seq = PL_cop_seqmax;
+    PERL_CONTEXT *cx;
 
 #ifdef USE_THREADS
     /*
@@ -333,6 +339,14 @@ pad_findmy(char *name)
        }
     }
 
+    /* Check if if we're in an eval'', and adjust seq to be the eval's
+     * seq number */
+    if (cxstack_ix >= 0) {
+       cx = &cxstack[cxstack_ix];
+       if (CxREALEVAL(cx))
+           seq = cx->blk_oldcop->cop_seq;
+    }
+
     /* See if it's in a nested scope */
     off = pad_findlex(name, 0, seq, CvOUTSIDE(PL_compcv), cxstack_ix, 0);
     if (off) {

diff --git a/pp_ctl.c b/pp_ctl.c
index b566738..332b24c 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -977,7 +977,7 @@ dopoptolabel(char *label)
 
     for (i = cxstack_ix; i >= 0; i--) {
        cx = &cxstack[i];
-       switch (cx->cx_type) {
+       switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting substitution via %s", 
@@ -1058,7 +1058,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
        cx = &cxstk[i];
-       switch (cx->cx_type) {
+       switch (CxTYPE(cx)) {
        default:
            continue;
        case CXt_EVAL:
@@ -1078,7 +1078,7 @@ dopoptoeval(I32 startingblock)
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
        cx = &cxstack[i];
-       switch (cx->cx_type) {
+       switch (CxTYPE(cx)) {
        default:
            continue;
        case CXt_EVAL:
@@ -1097,7 +1097,7 @@ dopoptoloop(I32 startingblock)
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
        cx = &cxstack[i];
-       switch (cx->cx_type) {
+       switch (CxTYPE(cx)) {
        case CXt_SUBST:
            if (ckWARN(WARN_UNSAFE))
                warner(WARN_UNSAFE, "Exiting substitution via %s", 
@@ -1137,9 +1137,9 @@ dounwind(I32 cxix)
     while (cxstack_ix > cxix) {
        cx = &cxstack[cxstack_ix];
        DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
-                             (long) cxstack_ix, block_type[cx->cx_type]));
+                             (long) cxstack_ix, block_type[CxTYPE(cx)]));
        /* Note: we don't need to restore the base context info till the end. */
-       switch (cx->cx_type) {
+       switch (CxTYPE(cx)) {
        case CXt_SUBST:
            POPSUBST(cx);
            continue;  /* not break */
@@ -1208,7 +1208,7 @@ die_where(char *message)
                dounwind(cxix);
 
            POPBLOCK(cx,PL_curpm);
-           if (cx->cx_type != CXt_EVAL) {
+           if (CxTYPE(cx) != CXt_EVAL) {
                PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
                my_exit(1);
            }
@@ -1298,7 +1298,7 @@ PP(pp_caller)
     }
 
     cx = &ccstack[cxix];
-    if (ccstack[cxix].cx_type == CXt_SUB) {
+    if (CxTYPE(cx) == CXt_SUB) {
         dbcxix = dopoptosub_at(ccstack, cxix - 1);
        /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
           field below is defined for any cx. */
@@ -1327,7 +1327,7 @@ PP(pp_caller)
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
        RETURN;
-    if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
+    if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
        sv = NEWSV(49, 0);
        gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
        PUSHs(sv_2mortal(sv));
@@ -1342,7 +1342,7 @@ PP(pp_caller)
        PUSHs(&PL_sv_undef);
     else
        PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
-    if (cx->cx_type == CXt_EVAL) {
+    if (CxTYPE(cx) == CXt_EVAL) {
        if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
            PUSHs(cx->blk_eval.cur_text);
            PUSHs(&PL_sv_no);
@@ -1353,7 +1353,7 @@ PP(pp_caller)
            PUSHs(&PL_sv_yes);
        }
     }
-    else if (cx->cx_type == CXt_SUB &&
+    else if (CxTYPE(cx) == CXt_SUB &&
            cx->blk_sub.hasargs &&
            PL_curcop->cop_stash == PL_debstash)
     {
@@ -1610,7 +1610,7 @@ PP(pp_return)
        dounwind(cxix);
 
     POPBLOCK(cx,newpm);
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_SUB:
        POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
        popsub2 = TRUE;
@@ -1698,7 +1698,7 @@ PP(pp_last)
        dounwind(cxix);
 
     POPBLOCK(cx,newpm);
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_LOOP:
        POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
        pop2 = CXt_LOOP;
@@ -1901,10 +1901,10 @@ PP(pp_goto)
            if (cxix < cxstack_ix)
                dounwind(cxix);
            TOPBLOCK(cx);
-           if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
+           if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
                DIE("Can't goto subroutine from an eval-string");
            mark = PL_stack_sp;
-           if (cx->cx_type == CXt_SUB &&
+           if (CxTYPE(cx) == CXt_SUB &&
                cx->blk_sub.hasargs) {   /* put @_ back onto stack */
                AV* av = cx->blk_sub.argarray;
                
@@ -1934,7 +1934,7 @@ PP(pp_goto)
                Copy(AvARRAY(av), PL_stack_sp, items, SV*);
                PL_stack_sp += items;
            }
-           if (cx->cx_type == CXt_SUB &&
+           if (CxTYPE(cx) == CXt_SUB &&
                !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
                SvREFCNT_dec(cx->blk_sub.cv);
            oldsave = PL_scopestack[PL_scopestack_ix - 1];
@@ -1973,7 +1973,7 @@ PP(pp_goto)
            else {
                AV* padlist = CvPADLIST(cv);
                SV** svp = AvARRAY(padlist);
-               if (cx->cx_type == CXt_EVAL) {
+               if (CxTYPE(cx) == CXt_EVAL) {
                    PL_in_eval = cx->blk_eval.old_in_eval;
                    PL_eval_root = cx->blk_eval.old_eval_root;
                    cx->cx_type = CXt_SUB;
@@ -2123,7 +2123,7 @@ PP(pp_goto)
        *enterops = 0;
        for (ix = cxstack_ix; ix >= 0; ix--) {
            cx = &cxstack[ix];
-           switch (cx->cx_type) {
+           switch (CxTYPE(cx)) {
            case CXt_EVAL:
                gotoprobe = PL_eval_root; /* XXX not good for nested eval */
                break;
@@ -2422,11 +2422,11 @@ doeval(int gimme, OP** startop)
     SAVEI32(PL_max_intro_pending);
 
     caller = PL_compcv;
-    for (i = cxstack_ix; i >= 0; i--) {
+    for (i = cxstack_ix - 1; i >= 0; i--) {
        PERL_CONTEXT *cx = &cxstack[i];
-       if (cx->cx_type == CXt_EVAL)
+       if (CxTYPE(cx) == CXt_EVAL)
            break;
-       else if (cx->cx_type == CXt_SUB) {
+       else if (CxTYPE(cx) == CXt_SUB) {
            caller = cx->blk_sub.cv;
            break;
        }
@@ -2772,7 +2772,7 @@ PP(pp_entereval)
     }
 
     push_return(PL_op->op_next);
-    PUSHBLOCK(cx, CXt_EVAL, SP);
+    PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
 
     /* prepare to compile string */

diff --git a/pp_hot.c b/pp_hot.c
index 701f462..f513c12 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1465,7 +1465,7 @@ PP(pp_iter)
 
     EXTEND(SP, 1);
     cx = &cxstack[cxstack_ix];
-    if (cx->cx_type != CXt_LOOP)
+    if (CxTYPE(cx) != CXt_LOOP)
        DIE("panic: pp_iter");
 
     av = cx->blk_loop.iterary;
@@ -2273,6 +2273,11 @@ PP(pp_entersub)
        PUSHBLOCK(cx, CXt_SUB, MARK);
        PUSHSUB(cx);
        CvDEPTH(cv)++;
+       /* XXX This would be a natural place to set C<PL_compcv = cv> so
+        * that eval'' ops within this sub know the correct lexical space.
+        * Owing the speed considerations, we choose to search for the cv
+        * in doeval() instead.
+        */
        if (CvDEPTH(cv) < 2)
            (void)SvREFCNT_inc(cv);
        else {  /* save temporaries on recursion? */

diff --git a/scope.c b/scope.c
index b603641..eb43648 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -841,8 +841,8 @@ cx_dump(PERL_CONTEXT *cx)
 {
 #ifdef DEBUGGING
     dTHR;
-    PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
-    if (cx->cx_type != CXt_SUBST) {
+    PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[CxTYPE(cx)]);
+    if (CxTYPE(cx) != CXt_SUBST) {
        PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
        PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
        PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
@@ -851,7 +851,7 @@ cx_dump(PERL_CONTEXT *cx)
        PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
        PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
     }
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_NULL:
     case CXt_BLOCK:
        break;

diff --git a/t/op/eval.t b/t/op/eval.t
index efa189e..5a9c198 100755 (executable)
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -100,3 +100,20 @@ do_eval('eval q[print "ok $x\n"]');
 $x++;
 do_eval('sub { eval q[print "ok $x\n"] }->()');
 $x++;
+
+# can recursive subroutine-call inside eval'' see its own lexicals?
+sub recurse {
+  my $l = shift;
+  if ($l < $x) {
+     ++$l;
+     eval 'print "# level $l\n"; recurse($l);';
+     die if $@;
+  }
+  else {
+    print "ok $l\n";
+  }
+}
+{
+  local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
+  recurse($x-5);
+}