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

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

p4raw-id: //depot/perl@20591

9 files changed, 43 insertions, 1 deletions

diff --git a/embed.fnc b/embed.fnc
index 6b2971d140..1e91c76288 100644
--- 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 5cbcb77afe..18b117a11a 100644
--- 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 2f47926bf0..8d0e0da275 100644
--- 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 bcf4fb63ad..6d3e312c14 100644
--- 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 76f2e5891c..3c2223a3e0 100644
--- 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 e8f3b842b5..e41659eff4 100644
--- 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 ff45b0da43..33d891e13a 100644
--- 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 a2e760e317..50b40faf7d 100644
--- 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 441fba29bd..568e2f4a05 100644
--- 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 {