This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
add some more tests for PL_cv_has_eval
[perl5.git] / t / op / closure.t
diff --git a/t/op/closure.t b/t/op/closure.t
old mode 100755 (executable)
new mode 100644 (file)
index dd7b50c..322b592
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -12,35 +12,27 @@ BEGIN {
 }
 
 use Config;
 }
 
 use Config;
-
-print "1..184\n";
-
-my $test = 1;
-sub test (&) {
-  my $ok = &{$_[0]};
-  print $ok ? "ok $test\n" : "not ok $test\n";
-  printf "# Failed at line %d\n", (caller)[2] unless $ok;
-  $test++;
-}
+require './test.pl';
 
 my $i = 1;
 sub foo { $i = shift if @_; $i }
 
 # no closure
 
 my $i = 1;
 sub foo { $i = shift if @_; $i }
 
 # no closure
-test { foo == 1 };
+is(foo, 1);
 foo(2);
 foo(2);
-test { foo == 2 };
+is(foo, 2);
 
 # closure: lexical outside sub
 my $foo = sub {$i = shift if @_; $i };
 my $bar = sub {$i = shift if @_; $i };
 
 # closure: lexical outside sub
 my $foo = sub {$i = shift if @_; $i };
 my $bar = sub {$i = shift if @_; $i };
-test {&$foo() == 2 };
+is(&$foo(), 2);
 &$foo(3);
 &$foo(3);
-test {&$foo() == 3 };
+is(&$foo(), 3);
 # did the lexical change?
 # did the lexical change?
-test { foo == 3 and $i == 3};
+is(foo, 3, 'lexical changed');
+is($i, 3, 'lexical changed');
 # did the second closure notice?
 # did the second closure notice?
-test {&$bar() == 3 };
+is(&$bar(), 3, 'second closure noticed');
 
 # closure: lexical inside sub
 sub bar {
 
 # closure: lexical inside sub
 sub bar {
@@ -50,10 +42,10 @@ sub bar {
 
 $foo = bar(4);
 $bar = bar(5);
 
 $foo = bar(4);
 $bar = bar(5);
-test {&$foo() == 4 };
+is(&$foo(), 4);
 &$foo(6);
 &$foo(6);
-test {&$foo() == 6 };
-test {&$bar() == 5 };
+is(&$foo(), 6);
+is(&$bar(), 5);
 
 # nested closures
 sub bizz {
 
 # nested closures
 sub bizz {
@@ -68,14 +60,14 @@ sub bizz {
 }
 $foo = bizz();
 $bar = bizz();
 }
 $foo = bizz();
 $bar = bizz();
-test {&$foo() == 7 };
+is(&$foo(), 7);
 &$foo(8);
 &$foo(8);
-test {&$foo() == 8 };
-test {&$bar() == 7 };
+is(&$foo(), 8);
+is(&$bar(), 7);
 
 $foo = bizz(9);
 $bar = bizz(10);
 
 $foo = bizz(9);
 $bar = bizz(10);
-test {&$foo(11)-1 == &$bar()};
+is(&$foo(11)-1, &$bar());
 
 my @foo;
 for (qw(0 1 2 3 4)) {
 
 my @foo;
 for (qw(0 1 2 3 4)) {
@@ -83,25 +75,21 @@ for (qw(0 1 2 3 4)) {
   $foo[$_] = sub {$i = shift if @_; $i };
 }
 
   $foo[$_] = sub {$i = shift if @_; $i };
 }
 
-test {
-  &{$foo[0]}() == 0 and
-  &{$foo[1]}() == 1 and
-  &{$foo[2]}() == 2 and
-  &{$foo[3]}() == 3 and
-  &{$foo[4]}() == 4
-  };
+is(&{$foo[0]}(), 0);
+is(&{$foo[1]}(), 1);
+is(&{$foo[2]}(), 2);
+is(&{$foo[3]}(), 3);
+is(&{$foo[4]}(), 4);
 
 for (0 .. 4) {
   &{$foo[$_]}(4-$_);
 }
 
 
 for (0 .. 4) {
   &{$foo[$_]}(4-$_);
 }
 
-test {
-  &{$foo[0]}() == 4 and
-  &{$foo[1]}() == 3 and
-  &{$foo[2]}() == 2 and
-  &{$foo[3]}() == 1 and
-  &{$foo[4]}() == 0
-  };
+is(&{$foo[0]}(), 4);
+is(&{$foo[1]}(), 3);
+is(&{$foo[2]}(), 2);
+is(&{$foo[3]}(), 1);
+is(&{$foo[4]}(), 0);
 
 sub barf {
   my @foo;
 
 sub barf {
   my @foo;
@@ -113,25 +101,21 @@ sub barf {
 }
 
 @foo = barf();
 }
 
 @foo = barf();
-test {
-  &{$foo[0]}() == 0 and
-  &{$foo[1]}() == 1 and
-  &{$foo[2]}() == 2 and
-  &{$foo[3]}() == 3 and
-  &{$foo[4]}() == 4
-  };
+is(&{$foo[0]}(), 0);
+is(&{$foo[1]}(), 1);
+is(&{$foo[2]}(), 2);
+is(&{$foo[3]}(), 3);
+is(&{$foo[4]}(), 4);
 
 for (0 .. 4) {
   &{$foo[$_]}(4-$_);
 }
 
 
 for (0 .. 4) {
   &{$foo[$_]}(4-$_);
 }
 
-test {
-  &{$foo[0]}() == 4 and
-  &{$foo[1]}() == 3 and
-  &{$foo[2]}() == 2 and
-  &{$foo[3]}() == 1 and
-  &{$foo[4]}() == 0
-  };
+is(&{$foo[0]}(), 4);
+is(&{$foo[1]}(), 3);
+is(&{$foo[2]}(), 2);
+is(&{$foo[3]}(), 1);
+is(&{$foo[4]}(), 0);
 
 # test if closures get created in optimized for loops
 
 
 # test if closures get created in optimized for loops
 
@@ -140,25 +124,21 @@ for my $n ('A'..'E') {
     $foo{$n} = sub { $n eq $_[0] };
 }
 
     $foo{$n} = sub { $n eq $_[0] };
 }
 
-test {
-  &{$foo{A}}('A') and
-  &{$foo{B}}('B') and
-  &{$foo{C}}('C') and
-  &{$foo{D}}('D') and
-  &{$foo{E}}('E')
-};
+ok(&{$foo{A}}('A'));
+ok(&{$foo{B}}('B'));
+ok(&{$foo{C}}('C'));
+ok(&{$foo{D}}('D'));
+ok(&{$foo{E}}('E'));
 
 for my $n (0..4) {
     $foo[$n] = sub { $n == $_[0] };
 }
 
 
 for my $n (0..4) {
     $foo[$n] = sub { $n == $_[0] };
 }
 
-test {
-  &{$foo[0]}(0) and
-  &{$foo[1]}(1) and
-  &{$foo[2]}(2) and
-  &{$foo[3]}(3) and
-  &{$foo[4]}(4)
-};
+ok(&{$foo[0]}(0));
+ok(&{$foo[1]}(1));
+ok(&{$foo[2]}(2));
+ok(&{$foo[3]}(3));
+ok(&{$foo[4]}(4));
 
 for my $n (0..4) {
     $foo[$n] = sub {
 
 for my $n (0..4) {
     $foo[$n] = sub {
@@ -167,19 +147,17 @@ for my $n (0..4) {
                   };
 }
 
                   };
 }
 
-test {
-  $foo[0]->()->(0) and
-  $foo[1]->()->(1) and
-  $foo[2]->()->(2) and
-  $foo[3]->()->(3) and
-  $foo[4]->()->(4)
-};
+ok($foo[0]->()->(0));
+ok($foo[1]->()->(1));
+ok($foo[2]->()->(2));
+ok($foo[3]->()->(3));
+ok($foo[4]->()->(4));
 
 {
     my $w;
     $w = sub {
        my ($i) = @_;
 
 {
     my $w;
     $w = sub {
        my ($i) = @_;
-       test { $i == 10 };
+       is($i, 10);
        sub { $w };
     };
     $w->(10);
        sub { $w };
     };
     $w->(10);
@@ -220,6 +198,7 @@ test {
        # a naked block, or another named sub
        for $within (qw!foreach naked other_sub!) {
 
        # a naked block, or another named sub
        for $within (qw!foreach naked other_sub!) {
 
+         my $test = curr_test();
          # Here are a number of variables which show what's
          # going on, in a way.
          $nc_attempt = 0+              # Named closure attempted
          # Here are a number of variables which show what's
          # going on, in a way.
          $nc_attempt = 0+              # Named closure attempted
@@ -262,15 +241,8 @@ END_MARK_TWO
     print "not ok: got unexpected warning \$msg\\n";
 } }
 
     print "not ok: got unexpected warning \$msg\\n";
 } }
 
-{
-    my \$test = $test;
-    sub test (&) {
-      my \$ok = &{\$_[0]};
-      print \$ok ? "ok \$test\n" : "not ok \$test\n";
-      printf "# Failed at line %d\n", (caller)[2] unless \$ok;
-      \$test++;
-    }
-}
+require './test.pl';
+curr_test($test);
 
 # some of the variables which the closure will access
 \$global_scalar = 1000;
 
 # some of the variables which the closure will access
 \$global_scalar = 1000;
@@ -424,10 +396,11 @@ END
            }
 
            # Here's the test:
            }
 
            # Here's the test:
+           my $desc = "$inner_type $where_declared $within $inner_sub_test";
            if ($inner_type eq 'anon') {
            if ($inner_type eq 'anon') {
-             $code .= "test { &\$anon_$test == $expected };\n"
+             $code .= "is(&\$anon_$test, $expected, '$desc');\n"
            } else {
            } else {
-             $code .= "test { &named_$test == $expected };\n"
+             $code .= "is(&named_$test, $expected, '$desc');\n"
            }
            $test++;
          }
            }
            $test++;
          }
@@ -446,8 +419,8 @@ END
              close READ2;
              open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
              open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
              close READ2;
              open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
              open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
-             exec './perl', '-w', '-'
-               or die "Can't exec ./perl: $!";
+             exec which_perl(), '-w', '-'
+               or die "Can't exec perl: $!";
            } else {
              # Parent process here.
              close WRITE;
            } else {
              # Parent process here.
              close WRITE;
@@ -462,15 +435,10 @@ END
            }
          } else {
            # No fork().  Do it the hard way.
            }
          } else {
            # No fork().  Do it the hard way.
-           my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
-           my $errfile = "terr$$";  $errfile++ while -e $errfile;
-           my @tmpfiles = ($cmdfile, $errfile);
+           my $cmdfile = tempfile();
+           my $errfile = tempfile();
            open CMD, ">$cmdfile"; print CMD $code; close CMD;
            open CMD, ">$cmdfile"; print CMD $code; close CMD;
-           my $cmd = (($^O eq 'VMS') ? "MCR $^X"
-                      : ($^O eq 'MSWin32') ? '.\perl'
-                      : ($^O eq 'MacOS') ? $^X
-                      : ($^O eq 'NetWare') ? 'perl'
-                      : './perl');
+           my $cmd = which_perl();
            $cmd .= " -w $cmdfile 2>$errfile";
            if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
              # Use pipe instead of system so we don't inherit STD* from
            $cmd .= " -w $cmdfile 2>$errfile";
            if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
              # Use pipe instead of system so we don't inherit STD* from
@@ -480,28 +448,31 @@ END
              { local $/; $output = join '', <PERL> }
              close PERL;
            } else {
              { local $/; $output = join '', <PERL> }
              close PERL;
            } else {
-             my $outfile = "tout$$";  $outfile++ while -e $outfile;
-             push @tmpfiles, $outfile;
+             my $outfile = tempfile();
              system "$cmd >$outfile";
              { local $/; open IN, $outfile; $output = <IN>; close IN }
            }
            if ($?) {
              printf "not ok: exited with error code %04X\n", $?;
              system "$cmd >$outfile";
              { local $/; open IN, $outfile; $output = <IN>; close IN }
            }
            if ($?) {
              printf "not ok: exited with error code %04X\n", $?;
-             $debugging or do { 1 while unlink @tmpfiles };
              exit;
            }
            { local $/; open IN, $errfile; $errors = <IN>; close IN }
              exit;
            }
            { local $/; open IN, $errfile; $errors = <IN>; close IN }
-           1 while unlink @tmpfiles;
          }
          print $output;
          }
          print $output;
+         curr_test($test);
          print STDERR $errors;
          print STDERR $errors;
+         # This has the side effect of alerting *our* test.pl to the state of
+         # what has just been passed to STDOUT, so that if anything there has
+         # failed, our test.pl will print a diagnostic and exit uncleanly.
+         unlike($output, qr/not ok/, 'All good');
+         is($errors, '', 'STDERR is silent');
          if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
            my $lnum = 0;
            for $line (split '\n', $code) {
              printf "%3d:  %s\n", ++$lnum, $line;
            }
          }
          if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
            my $lnum = 0;
            for $line (split '\n', $code) {
              printf "%3d:  %s\n", ++$lnum, $line;
            }
          }
-         printf "not ok: exited with error code %04X\n", $? if $?;
+         is($?, 0, 'exited cleanly') or diag(sprintf "Error code $? = 0x%X", $?);
          print '#', "-" x 30, "\n" if $debugging;
 
        }       # End of foreach $within
          print '#', "-" x 30, "\n" if $debugging;
 
        }       # End of foreach $within
@@ -513,7 +484,7 @@ END
 # The following dumps core with perl <= 5.8.0 (bugid 9535) ...
 BEGIN { $vanishing_pad = sub { eval $_[0] } }
 $some_var = 123;
 # The following dumps core with perl <= 5.8.0 (bugid 9535) ...
 BEGIN { $vanishing_pad = sub { eval $_[0] } }
 $some_var = 123;
-test { $vanishing_pad->( '$some_var' ) == 123 };
+is($vanishing_pad->('$some_var'), 123, 'RT #9535');
 
 # ... and here's another coredump variant - this time we explicitly
 # delete the sub rather than using a BEGIN ...
 
 # ... and here's another coredump variant - this time we explicitly
 # delete the sub rather than using a BEGIN ...
@@ -522,7 +493,7 @@ sub deleteme { $a = sub { eval '$newvar' } }
 deleteme();
 *deleteme = sub {}; # delete the sub
 $newvar = 123; # realloc the SV of the freed CV
 deleteme();
 *deleteme = sub {}; # delete the sub
 $newvar = 123; # realloc the SV of the freed CV
-test { $a->() == 123 };
+is($a->(), 123, 'RT #9535');
 
 # ... and a further coredump variant - the fixup of the anon sub's
 # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
 
 # ... and a further coredump variant - the fixup of the anon sub's
 # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
@@ -535,7 +506,7 @@ $a = eval q(
     ]
 );
 @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
     ]
 );
 @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
-test { $a->() == 123 };
+is($a->(), 123, 'RT #9535');
 
 # this coredumped on <= 5.8.0 because evaling the closure caused
 # an SvFAKE to be added to the outer anon's pad, which was then grown.
 
 # this coredumped on <= 5.8.0 because evaling the closure caused
 # an SvFAKE to be added to the outer anon's pad, which was then grown.
@@ -547,14 +518,14 @@ sub {
     $a = [ 99 ];
     $x->();
 }->();
     $a = [ 99 ];
     $x->();
 }->();
-test {1};
+pass();
 
 # [perl #17605] found that an empty block called in scalar context
 # can lead to stack corruption
 {
     my $x = "foooobar";
     $x =~ s/o//eg;
 
 # [perl #17605] found that an empty block called in scalar context
 # can lead to stack corruption
 {
     my $x = "foooobar";
     $x =~ s/o//eg;
-    test { $x eq 'fbar' }
+    is($x, 'fbar', 'RT #17605');
 }
 
 # DAPM 24-Nov-02
 }
 
 # DAPM 24-Nov-02
@@ -564,22 +535,21 @@ test {1};
 {
     my $x = 1;
     sub fake {
 {
     my $x = 1;
     sub fake {
-               test { sub {eval'$x'}->() == 1 };
-       { $x;   test { sub {eval'$x'}->() == 1 } }
-               test { sub {eval'$x'}->() == 1 };
+               is(sub {eval'$x'}->(), 1, 'RT #18286');
+       { $x;   is(sub {eval'$x'}->(), 1, 'RT #18286'); }
+               is(sub {eval'$x'}->(), 1, 'RT #18286');
     }
 }
 fake();
 
     }
 }
 fake();
 
-# undefining a sub shouldn't alter visibility of outer lexicals
-
 {
     $x = 1;
     my $x = 2;
     sub tmp { sub { eval '$x' } }
     my $a = tmp();
     undef &tmp;
 {
     $x = 1;
     my $x = 2;
     sub tmp { sub { eval '$x' } }
     my $a = tmp();
     undef &tmp;
-    test { $a->() == 2 };
+    is($a->(), 2,
+       "undefining a sub shouldn't alter visibility of outer lexicals");
 }
 
 # handy class: $x = Watch->new(\$foo,'bar')
 }
 
 # handy class: $x = Watch->new(\$foo,'bar')
@@ -587,7 +557,6 @@ fake();
 sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
 sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
 
 sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
 sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
 
-
 # bugid 1028:
 # nested anon subs (and associated lexicals) not freed early enough
 
 # bugid 1028:
 # nested anon subs (and associated lexicals) not freed early enough
 
@@ -602,7 +571,7 @@ sub linger {
 {
     my $watch = '1';
     linger(\$watch);
 {
     my $watch = '1';
     linger(\$watch);
-    test { $watch eq '12' }
+    is($watch, '12', 'RT #1028');
 }
 
 # bugid 10085
 }
 
 # bugid 10085
@@ -615,7 +584,7 @@ sub linger2 {
 {
     my $watch = '1';
     linger2(\$watch);
 {
     my $watch = '1';
     linger2(\$watch);
-    test { $watch eq '12' }
+    is($watch, 12, 'RT #10085');
 }
 
 # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
 }
 
 # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
@@ -624,7 +593,7 @@ sub linger2 {
     my $x = 1;
     sub f16302 {
        sub {
     my $x = 1;
     sub f16302 {
        sub {
-           test { defined $x and $x == 1 }
+           is($x, 1, 'RT #16302');
        }->();
     }
 }
        }->();
     }
 }
@@ -638,7 +607,99 @@ f16302();
     for my $x (7,11) {
        $a{$x} = sub { $x=$x; sub { eval '$x' } };
     }
     for my $x (7,11) {
        $a{$x} = sub { $x=$x; sub { eval '$x' } };
     }
-    test { $a{7}->()->() + $a{11}->()->() == 18 };
+    is($a{7}->()->() + $a{11}->()->(), 18);
+}
+
+{
+   # bugid #23265 - this used to coredump during destruction of PL_maincv
+   # and its children
+
+    fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265');
+        print
+            sub {$_[0]->(@_)} -> (
+                sub {
+                    $_[1]
+                        ?  $_[0]->($_[0], $_[1] - 1) .  sub {"x"}->()
+                        : "y"
+                },   
+                2
+            )
+            , "\n"
+        ;
+__EOF__
+}
+
+{
+    # bugid #24914 = used to coredump restoring PL_comppad in the
+    # savestack, due to the early freeing of the anon closure
+
+    fresh_perl_is('sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)',
+                 "ok\n", {stderr => 1}, 'RT #24914');
 }
 
 
 }
 
 
+# After newsub is redefined outside the BEGIN, its CvOUTSIDE should point
+# to main rather than BEGIN, and BEGIN should be freed.
+
+{
+    my $flag = 0;
+    sub  X::DESTROY { $flag = 1 }
+    {
+       my $x;
+       BEGIN {$x = \&newsub }
+       sub newsub {};
+       $x = bless {}, 'X';
+    }
+    is($flag, 1);
+}
+
+sub f {
+    my $x if $_[0];
+    sub { \$x }
+}
+
+{
+    f(1);
+    my $c1= f(0);
+    my $c2= f(0);
+
+    my $r1 = $c1->();
+    my $r2 = $c2->();
+    isnt($r1, $r2,
+        "don't copy a stale lexical; crate a fresh undef one instead");
+}
+
+# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
+
+BEGIN {
+  my $x = 7;
+  *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 }
+}
+{
+  my $blonk_was_called;
+  *blonk = sub { ++$blonk_was_called };
+  my $ret = baz();
+  is($ret, 0, 'RT #63540');
+  is($blonk_was_called, 1, 'RT #63540');
+}
+
+# test PL_cv_has_eval.  Any anon sub that could conceivably contain an
+# eval, should be marked as cloneable
+
+{
+
+    my @s;
+    push @s, sub {  eval '1' } for 1,2;
+    isnt($s[0], $s[1], "cloneable with eval");
+    @s = ();
+    push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2;
+    isnt($s[0], $s[1], "cloneable with use re eval");
+    @s = ();
+    push @s, sub { s/1/1/ee; } for 1,2;
+    isnt($s[0], $s[1], "cloneable with //ee");
+}
+
+
+
+
+done_testing();
Unnamed repository; edit this file 'description' to name the repository.