This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate change #7784 from mainline into maintperl.
authorJarkko Hietaniemi <jhi@iki.fi>
Wed, 7 Mar 2001 22:59:39 +0000 (22:59 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Wed, 7 Mar 2001 22:59:39 +0000 (22:59 +0000)
Subject: [PATCH 5.7.0] lexicals not recognized in a run-time (?{})

p4raw-link: @7784 on //depot/perl: 160cb4296c4a58b0681dec6838a7a7ad23e4b244

p4raw-id: //depot/maint-5.6/perl@9076
p4raw-integrated: from //depot/perl@7784 'merge in' pp_ctl.c (@7742..)
t/op/pat.t (@7761..)

pp_ctl.c
t/op/pat.t

index 86fda1a..1816b6d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2736,7 +2736,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     PL_op = &dummy;
     PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;                       /* Avoid uninit warning. */
-    PUSHBLOCK(cx, CXt_EVAL, SP);
+    PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
     PUSHEVAL(cx, 0, Nullgv);
     rop = doeval(G_SCALAR, startop);
     POPBLOCK(cx,PL_curpm);
index ef76241..5dc26a9 100755 (executable)
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..225\n";
+print "1..231\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -545,6 +545,22 @@ $test++;
   print "ok $test\n";
   $test++;
 
+  local $lex_a = 2;
+  my $lex_a = 43;
+  my $lex_b = 17;
+  my $lex_c = 27;
+  my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
+  print "not " unless $lex_res eq '1';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_a eq '44';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_c eq '43';
+  print "ok $test\n";
+  $test++;
+
+
   no re "eval"; 
   $match = eval { /$a$c$a/ };
   print "not " 
@@ -554,6 +570,23 @@ $test++;
 }
 
 {
+  local $lex_a = 2;
+  my $lex_a = 43;
+  my $lex_b = 17;
+  my $lex_c = 27;
+  my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
+  print "not " unless $lex_res eq '1';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_a eq '44';
+  print "ok $test\n";
+  $test++;
+  print "not " unless $lex_c eq '43';
+  print "ok $test\n";
+  $test++;
+}
+
+{
   package aa;
   $c = 2;
   $::c = 3;