}
use Config;
-require './test.pl'; # for runperl()
-
-print "1..188\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
-test { foo == 1 };
+is(foo, 1);
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 };
-test {&$foo() == 2 };
+is(&$foo(), 2);
&$foo(3);
-test {&$foo() == 3 };
+is(&$foo(), 3);
# 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?
-test {&$bar() == 3 };
+is(&$bar(), 3, 'second closure noticed');
# closure: lexical inside sub
sub bar {
$foo = bar(4);
$bar = bar(5);
-test {&$foo() == 4 };
+is(&$foo(), 4);
&$foo(6);
-test {&$foo() == 6 };
-test {&$bar() == 5 };
+is(&$foo(), 6);
+is(&$bar(), 5);
# nested closures
sub bizz {
}
$foo = bizz();
$bar = bizz();
-test {&$foo() == 7 };
+is(&$foo(), 7);
&$foo(8);
-test {&$foo() == 8 };
-test {&$bar() == 7 };
+is(&$foo(), 8);
+is(&$bar(), 7);
$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)) {
$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-$_);
}
-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;
}
@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-$_);
}
-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
$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] };
}
-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 {
};
}
-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) = @_;
- test { $i == 10 };
+ is($i, 10);
sub { $w };
};
$w->(10);
# 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
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;
}
# Here's the test:
+ my $desc = "$inner_type $where_declared $within $inner_sub_test";
if ($inner_type eq 'anon') {
- $code .= "test { &\$anon_$test == $expected };\n"
+ $code .= "is(&\$anon_$test, $expected, '$desc');\n"
} else {
- $code .= "test { &named_$test == $expected };\n"
+ $code .= "is(&named_$test, $expected, '$desc');\n"
}
$test++;
}
}
} 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;
my $cmd = which_perl();
$cmd .= " -w $cmdfile 2>$errfile";
{ 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", $?;
- $debugging or do { 1 while unlink @tmpfiles };
exit;
}
{ local $/; open IN, $errfile; $errors = <IN>; close IN }
- 1 while unlink @tmpfiles;
}
print $output;
+ curr_test($test);
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;
}
}
- 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
# 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 ...
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
]
);
@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.
$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;
- test { $x eq 'fbar' }
+ is($x, 'fbar', 'RT #17605');
}
# DAPM 24-Nov-02
{
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();
-# 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;
- test { $a->() == 2 };
+ is($a->(), 2,
+ "undefining a sub shouldn't alter visibility of outer lexicals");
}
# handy class: $x = Watch->new(\$foo,'bar')
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
{
my $watch = '1';
linger(\$watch);
- test { $watch eq '12' }
+ is($watch, '12', 'RT #1028');
}
# bugid 10085
{
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
my $x = 1;
sub f16302 {
sub {
- test { defined $x and $x == 1 }
+ is($x, 1, 'RT #16302');
}->();
}
}
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
- my $progfile = "b23265.pl";
- open(T, ">$progfile") or die "$0: $!\n";
- print T << '__EOF__';
+ fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265');
print
sub {$_[0]->(@_)} -> (
sub {
, "\n"
;
__EOF__
- close T;
- my $got = runperl(progfile => $progfile);
- test { chomp $got; $got eq "yxx" };
- END { 1 while unlink $progfile }
}
{
# bugid #24914 = used to coredump restoring PL_comppad in the
# savestack, due to the early freeing of the anon closure
- my $got = runperl(stderr => 1, prog =>
-'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
- );
- test { $got eq "ok\n" };
+ 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, it's CvOUTSIDE should point
+
+# After newsub is redefined outside the BEGIN, its CvOUTSIDE should point
# to main rather than BEGIN, and BEGIN should be freed.
{
sub newsub {};
$x = bless {}, 'X';
}
- test { $flag == 1 };
+ is($flag, 1);
}
-# don't copy a stale lexical; crate a fresh undef one instead
-
sub f {
my $x if $_[0];
sub { \$x }
my $r1 = $c1->();
my $r2 = $c2->();
- test { $r1 != $r2 };
+ 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();