add "$lexical not available" warning in C<for my $lex ()>

Message-ID: <20030809135144.GC4997@fdgroup.com>

p4raw-id: //depot/perl@20591

diff --git a/embed.fnc b/embed.fnc
index 6b2971d..1e91c76 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1391,6 +1391,7 @@ p |void   |free_tied_hv_pool
 #if defined(DEBUGGING)
 p      |int    |get_debug_opts |char **s
 #endif
+Ap     |void   |save_set_svflags|SV* sv|U32 mask|U32 val
 
 
 

diff --git a/embed.h b/embed.h
index 5cbcb77..18b117a 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2148,6 +2148,7 @@
 #define get_debug_opts         Perl_get_debug_opts
 #endif
 #endif
+#define save_set_svflags       Perl_save_set_svflags
 #define ck_anoncode            Perl_ck_anoncode
 #define ck_bitop               Perl_ck_bitop
 #define ck_concat              Perl_ck_concat
@@ -4632,6 +4633,7 @@
 #define get_debug_opts(a)      Perl_get_debug_opts(aTHX_ a)
 #endif
 #endif
+#define save_set_svflags(a,b,c)        Perl_save_set_svflags(aTHX_ a,b,c)
 #define ck_anoncode(a)         Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)            Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)           Perl_ck_concat(aTHX_ a)

diff --git a/global.sym b/global.sym
index 2f47926..8d0e0da 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -660,3 +660,4 @@ Perl_PerlIO_get_cnt
 Perl_PerlIO_stdin
 Perl_PerlIO_stdout
 Perl_PerlIO_stderr
+Perl_save_set_svflags

diff --git a/op.c b/op.c
index bcf4fb6..6d3e312 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3751,7 +3751,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
                               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 */
+     * for our $x () sets OPpOUR_INTRO */
     loop->op_private = (U8)iterpflags;
 #ifdef PL_OP_SLAB_ALLOC
     {

diff --git a/pp_ctl.c b/pp_ctl.c
index 76f2e58..3c2223a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1731,6 +1731,11 @@ PP(pp_enteriter)
     SAVETMPS;
 
     if (PL_op->op_targ) {
+       if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
+           SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
+           SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
+                   SVs_PADSTALE, SVs_PADSTALE);
+       }
 #ifndef USE_ITHREADS
        svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
        SAVESPTR(*svp);

diff --git a/proto.h b/proto.h
index e8f3b84..e41659e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1331,6 +1331,7 @@ PERL_CALLCONV void        Perl_free_tied_hv_pool(pTHX);
 #if defined(DEBUGGING)
 PERL_CALLCONV int      Perl_get_debug_opts(pTHX_ char **s);
 #endif
+PERL_CALLCONV void     Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val);
 
 
 

diff --git a/scope.c b/scope.c
index ff45b0d..33d891e 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -281,6 +281,18 @@ Perl_save_shared_pvref(pTHX_ char **str)
     SSPUSHINT(SAVEt_SHARED_PVREF);
 }
 
+/* set the SvFLAGS specified by mask to the values in val */
+
+void
+Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
+{
+    SSCHECK(4);
+    SSPUSHPTR(sv);
+    SSPUSHINT(mask);
+    SSPUSHINT(val);
+    SSPUSHINT(SAVEt_SET_SVFLAGS);
+}
+
 void
 Perl_save_gp(pTHX_ GV *gv, I32 empty)
 {
@@ -1036,6 +1048,15 @@ Perl_leave_scope(pTHX_ I32 base)
                    AvARRAY((PAD*)ptr)[off] = (SV*)SSPOPPTR;
            }
            break;
+       case SAVEt_SET_SVFLAGS:
+           {
+               U32 val  = (U32)SSPOPINT;
+               U32 mask = (U32)SSPOPINT;
+               sv = (SV*)SSPOPPTR;
+               SvFLAGS(sv) &= ~mask;
+               SvFLAGS(sv) |= val;
+           }
+           break;
        default:
            Perl_croak(aTHX_ "panic: leave_scope inconsistency");
        }

diff --git a/scope.h b/scope.h
index a2e760e..50b40fa 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -47,6 +47,7 @@
 #define SAVEt_MORTALIZESV      36
 #define SAVEt_SHARED_PVREF     37
 #define SAVEt_BOOL             38
+#define SAVEt_SET_SVFLAGS      39
 
 #ifndef SCOPE_SAVES_SIGNAL_MASK
 #define SCOPE_SAVES_SIGNAL_MASK 0
@@ -132,6 +133,7 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 #define SAVEGENERICSV(s)       save_generic_svref((SV**)&(s))
 #define SAVEGENERICPV(s)       save_generic_pvref((char**)&(s))
 #define SAVESHAREDPV(s)                save_shared_pvref((char**)&(s))
+#define SAVESETSVFLAGS(sv,mask,val)    save_set_svflags(sv,mask,val)
 #define SAVEDELETE(h,k,l) \
          save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l))
 #define SAVEDESTRUCTOR(f,p) \

diff --git a/t/lib/warnings/pad b/t/lib/warnings/pad
index 441fba2..568e2f4 100644 (file)
--- a/t/lib/warnings/pad
+++ b/t/lib/warnings/pad
@@ -159,6 +159,15 @@ f2();
 EXPECT
 Variable "$x" is not available at (eval 1) line 2.
 ########
+use warnings 'closure' ;
+for my $x (1,2,3) {
+    sub f { eval '$x' }
+    f();
+}
+f();
+EXPECT
+Variable "$x" is not available at (eval 4) line 2.
+########
 # pad.c
 no warnings 'closure' ;
 sub x {