+#!./perl
+# -*- Mode: Perl -*-
+# closure.t:
+# Original written by Ulrich Pfeifer on 2 Jan 1997.
+# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
+#
+# Run with -debug for debugging output.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+print "1..187\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++;
+}
+
+my $i = 1;
+sub foo { $i = shift if @_; $i }
+
+# no closure
+test { foo == 1 };
+foo(2);
+test { foo == 2 };
+
+# closure: lexical outside sub
+my $foo = sub {$i = shift if @_; $i };
+my $bar = sub {$i = shift if @_; $i };
+test {&$foo() == 2 };
+&$foo(3);
+test {&$foo() == 3 };
+# did the lexical change?
+test { foo == 3 and $i == 3};
+# did the second closure notice?
+test {&$bar() == 3 };
+
+# closure: lexical inside sub
+sub bar {
+ my $i = shift;
+ sub { $i = shift if @_; $i }
+}
+
+$foo = bar(4);
+$bar = bar(5);
+test {&$foo() == 4 };
+&$foo(6);
+test {&$foo() == 6 };
+test {&$bar() == 5 };
+
+# nested closures
+sub bizz {
+ my $i = 7;
+ if (@_) {
+ my $i = shift;
+ sub {$i = shift if @_; $i };
+ } else {
+ my $i = $i;
+ sub {$i = shift if @_; $i };
+ }
+}
+$foo = bizz();
+$bar = bizz();
+test {&$foo() == 7 };
+&$foo(8);
+test {&$foo() == 8 };
+test {&$bar() == 7 };
+
+$foo = bizz(9);
+$bar = bizz(10);
+test {&$foo(11)-1 == &$bar()};
+
+my @foo;
+for (qw(0 1 2 3 4)) {
+ my $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
+ };
+
+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
+ };
+
+sub barf {
+ my @foo;
+ for (qw(0 1 2 3 4)) {
+ my $i = $_;
+ $foo[$_] = sub {$i = shift if @_; $i };
+ }
+ @foo;
+}
+
+@foo = barf();
+test {
+ &{$foo[0]}() == 0 and
+ &{$foo[1]}() == 1 and
+ &{$foo[2]}() == 2 and
+ &{$foo[3]}() == 3 and
+ &{$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
+ };
+
+# test if closures get created in optimized for loops
+
+my %foo;
+for my $n ('A'..'E') {
+ $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')
+};
+
+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)
+};
+
+for my $n (0..4) {
+ $foo[$n] = sub {
+ # no intervening reference to $n here
+ sub { $n == $_[0] }
+ };
+}
+
+test {
+ $foo[0]->()->(0) and
+ $foo[1]->()->(1) and
+ $foo[2]->()->(2) and
+ $foo[3]->()->(3) and
+ $foo[4]->()->(4)
+};
+
+{
+ my $w;
+ $w = sub {
+ my ($i) = @_;
+ test { $i == 10 };
+ sub { $w };
+ };
+ $w->(10);
+}
+
+# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
+
+{
+ use strict;
+
+ use vars qw!$test!;
+ my($debugging, %expected, $inner_type, $where_declared, $within);
+ my($nc_attempt, $call_outer, $call_inner, $undef_outer);
+ my($code, $inner_sub_test, $expected, $line, $errors, $output);
+ my(@inners, $sub_test, $pid);
+ $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
+
+ # The expected values for these tests
+ %expected = (
+ 'global_scalar' => 1001,
+ 'global_array' => 2101,
+ 'global_hash' => 3004,
+ 'fs_scalar' => 4001,
+ 'fs_array' => 5101,
+ 'fs_hash' => 6004,
+ 'sub_scalar' => 7001,
+ 'sub_array' => 8101,
+ 'sub_hash' => 9004,
+ 'foreach' => 10011,
+ );
+
+ # Our innermost sub is either named or anonymous
+ for $inner_type (qw!named anon!) {
+ # And it may be declared at filescope, within a named
+ # sub, or within an anon sub
+ for $where_declared (qw!filescope in_named in_anon!) {
+ # And that, in turn, may be within a foreach loop,
+ # a naked block, or another named sub
+ for $within (qw!foreach naked other_sub!) {
+
+ # Here are a number of variables which show what's
+ # going on, in a way.
+ $nc_attempt = 0+ # Named closure attempted
+ ( ($inner_type eq 'named') ||
+ ($within eq 'other_sub') ) ;
+ $call_inner = 0+ # Need to call &inner
+ ( ($inner_type eq 'anon') &&
+ ($within eq 'other_sub') ) ;
+ $call_outer = 0+ # Need to call &outer or &$outer
+ ( ($inner_type eq 'anon') &&
+ ($within ne 'other_sub') ) ;
+ $undef_outer = 0+ # $outer is created but unused
+ ( ($where_declared eq 'in_anon') &&
+ (not $call_outer) ) ;
+
+ $code = "# This is a test script built by t/op/closure.t\n\n";
+
+ print <<"DEBUG_INFO" if $debugging;
+# inner_type: $inner_type
+# where_declared: $where_declared
+# within: $within
+# nc_attempt: $nc_attempt
+# call_inner: $call_inner
+# call_outer: $call_outer
+# undef_outer: $undef_outer
+DEBUG_INFO
+
+ $code .= <<"END_MARK_ONE";
+
+BEGIN { \$SIG{__WARN__} = sub {
+ my \$msg = \$_[0];
+END_MARK_ONE
+
+ $code .= <<"END_MARK_TWO" if $nc_attempt;
+ return if index(\$msg, 'will not stay shared') != -1;
+ return if index(\$msg, 'is not available') != -1;
+END_MARK_TWO
+
+ $code .= <<"END_MARK_THREE"; # Backwhack a lot!
+ 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++;
+ }
+}
+
+# some of the variables which the closure will access
+\$global_scalar = 1000;
+\@global_array = (2000, 2100, 2200, 2300);
+%global_hash = 3000..3009;
+
+my \$fs_scalar = 4000;
+my \@fs_array = (5000, 5100, 5200, 5300);
+my %fs_hash = 6000..6009;
+
+END_MARK_THREE
+
+ if ($where_declared eq 'filescope') {
+ # Nothing here
+ } elsif ($where_declared eq 'in_named') {
+ $code .= <<'END';
+sub outer {
+ my $sub_scalar = 7000;
+ my @sub_array = (8000, 8100, 8200, 8300);
+ my %sub_hash = 9000..9009;
+END
+ # }
+ } elsif ($where_declared eq 'in_anon') {
+ $code .= <<'END';
+$outer = sub {
+ my $sub_scalar = 7000;
+ my @sub_array = (8000, 8100, 8200, 8300);
+ my %sub_hash = 9000..9009;
+END
+ # }
+ } else {
+ die "What was $where_declared?"
+ }
+
+ if ($within eq 'foreach') {
+ $code .= "
+ my \$foreach = 12000;
+ my \@list = (10000, 10010);
+ foreach \$foreach (\@list) {
+ " # }
+ } elsif ($within eq 'naked') {
+ $code .= " { # naked block\n" # }
+ } elsif ($within eq 'other_sub') {
+ $code .= " sub inner_sub {\n" # }
+ } else {
+ die "What was $within?"
+ }
+
+ $sub_test = $test;
+ @inners = ( qw!global_scalar global_array global_hash! ,
+ qw!fs_scalar fs_array fs_hash! );
+ push @inners, 'foreach' if $within eq 'foreach';
+ if ($where_declared ne 'filescope') {
+ push @inners, qw!sub_scalar sub_array sub_hash!;
+ }
+ for $inner_sub_test (@inners) {
+
+ if ($inner_type eq 'named') {
+ $code .= " sub named_$sub_test "
+ } elsif ($inner_type eq 'anon') {
+ $code .= " \$anon_$sub_test = sub "
+ } else {
+ die "What was $inner_type?"
+ }
+
+ # Now to write the body of the test sub
+ if ($inner_sub_test eq 'global_scalar') {
+ $code .= '{ ++$global_scalar }'
+ } elsif ($inner_sub_test eq 'fs_scalar') {
+ $code .= '{ ++$fs_scalar }'
+ } elsif ($inner_sub_test eq 'sub_scalar') {
+ $code .= '{ ++$sub_scalar }'
+ } elsif ($inner_sub_test eq 'global_array') {
+ $code .= '{ ++$global_array[1] }'
+ } elsif ($inner_sub_test eq 'fs_array') {
+ $code .= '{ ++$fs_array[1] }'
+ } elsif ($inner_sub_test eq 'sub_array') {
+ $code .= '{ ++$sub_array[1] }'
+ } elsif ($inner_sub_test eq 'global_hash') {
+ $code .= '{ ++$global_hash{3002} }'
+ } elsif ($inner_sub_test eq 'fs_hash') {
+ $code .= '{ ++$fs_hash{6002} }'
+ } elsif ($inner_sub_test eq 'sub_hash') {
+ $code .= '{ ++$sub_hash{9002} }'
+ } elsif ($inner_sub_test eq 'foreach') {
+ $code .= '{ ++$foreach }'
+ } else {
+ die "What was $inner_sub_test?"
+ }
+
+ # Close up
+ if ($inner_type eq 'anon') {
+ $code .= ';'
+ }
+ $code .= "\n";
+ $sub_test++; # sub name sequence number
+
+ } # End of foreach $inner_sub_test
+
+ # Close up $within block # {
+ $code .= " }\n\n";
+
+ # Close up $where_declared block
+ if ($where_declared eq 'in_named') { # {
+ $code .= "}\n\n";
+ } elsif ($where_declared eq 'in_anon') { # {
+ $code .= "};\n\n";
+ }
+
+ # We may need to do something with the sub we just made...
+ $code .= "undef \$outer;\n" if $undef_outer;
+ $code .= "&inner_sub;\n" if $call_inner;
+ if ($call_outer) {
+ if ($where_declared eq 'in_named') {
+ $code .= "&outer;\n\n";
+ } elsif ($where_declared eq 'in_anon') {
+ $code .= "&\$outer;\n\n"
+ }
+ }
+
+ # Now, we can actually prep to run the tests.
+ for $inner_sub_test (@inners) {
+ $expected = $expected{$inner_sub_test} or
+ die "expected $inner_sub_test missing";
+
+ # Named closures won't access the expected vars
+ if ( $nc_attempt and
+ substr($inner_sub_test, 0, 4) eq "sub_" ) {
+ $expected = 1;
+ }
+
+ # If you make a sub within a foreach loop,
+ # what happens if it tries to access the
+ # foreach index variable? If it's a named
+ # sub, it gets the var from "outside" the loop,
+ # but if it's anon, it gets the value to which
+ # the index variable is aliased.
+ #
+ # Of course, if the value was set only
+ # within another sub which was never called,
+ # the value has not been set yet.
+ #
+ if ($inner_sub_test eq 'foreach') {
+ if ($inner_type eq 'named') {
+ if ($call_outer || ($where_declared eq 'filescope')) {
+ $expected = 12001
+ } else {
+ $expected = 1
+ }
+ }
+ }
+
+ # Here's the test:
+ if ($inner_type eq 'anon') {
+ $code .= "test { &\$anon_$test == $expected };\n"
+ } else {
+ $code .= "test { &named_$test == $expected };\n"
+ }
+ $test++;
+ }
+
+ if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
+ # Fork off a new perl to run the tests.
+ # (This is so we can catch spurious warnings.)
+ $| = 1; print ""; $| = 0; # flush output before forking
+ pipe READ, WRITE or die "Can't make pipe: $!";
+ pipe READ2, WRITE2 or die "Can't make second pipe: $!";
+ die "Can't fork: $!" unless defined($pid = open PERL, "|-");
+ unless ($pid) {
+ # Child process here. We're going to send errors back
+ # through the extra pipe.
+ close READ;
+ 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: $!";
+ } else {
+ # Parent process here.
+ close WRITE;
+ close WRITE2;
+ print PERL $code;
+ close PERL;
+ { local $/;
+ $output = join '', <READ>;
+ $errors = join '', <READ2>; }
+ close READ;
+ close READ2;
+ }
+ } 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);
+ 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');
+ $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
+ # this process, and then foul our pipe back to parent by
+ # redirecting output in the child.
+ open PERL,"$cmd |" or die "Can't open pipe: $!\n";
+ { local $/; $output = join '', <PERL> }
+ close PERL;
+ } else {
+ my $outfile = "tout$$"; $outfile++ while -e $outfile;
+ push @tmpfiles, $outfile;
+ 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;
+ print STDERR $errors;
+ 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 $?;
+ print '#', "-" x 30, "\n" if $debugging;
+
+ } # End of foreach $within
+ } # End of foreach $where_declared
+ } # End of foreach $inner_type
+
+}
+
+# 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 };
+
+# ... and here's another coredump variant - this time we explicitly
+# delete the sub rather than using a BEGIN ...
+
+sub deleteme { $a = sub { eval '$newvar' } }
+deleteme();
+*deleteme = sub {}; # delete the sub
+$newvar = 123; # realloc the SV of the freed CV
+test { $a->() == 123 };
+
+# ... 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
+# survive the outer eval also being freed.
+
+$x = 123;
+$a = eval q(
+ eval q[
+ sub { eval '$x' }
+ ]
+);
+@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
+test { $a->() == 123 };
+
+# 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.
+my $outer;
+sub {
+ my $x;
+ $x = eval 'sub { $outer }';
+ $x->();
+ $a = [ 99 ];
+ $x->();
+}->();
+test {1};
+
+# [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' }
+}
+
+# DAPM 24-Nov-02
+# SvFAKE lexicals should be visible thoughout a function.
+# On <= 5.8.0, the third test failed, eg bugid #18286
+
+{
+ my $x = 1;
+ sub fake {
+ test { sub {eval'$x'}->() == 1 };
+ { $x; test { sub {eval'$x'}->() == 1 } }
+ test { sub {eval'$x'}->() == 1 };
+ }
+}
+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 };
+}
+
+# handy class: $x = Watch->new(\$foo,'bar')
+# causes 'bar' to be appended to $foo when $x is destroyed
+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
+
+sub linger {
+ my $x = Watch->new($_[0], '2');
+ sub {
+ $x;
+ my $y;
+ sub { $y; };
+ };
+}
+{
+ my $watch = '1';
+ linger(\$watch);
+ test { $watch eq '12' }
+}
+
+# bugid 10085
+# obj not freed early enough
+
+sub linger2 {
+ my $obj = Watch->new($_[0], '2');
+ sub { sub { $obj } };
+}
+{
+ my $watch = '1';
+ linger2(\$watch);
+ test { $watch eq '12' }
+}
+
+# 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 }
+ }->();
+ }
+}
+f16302();
+
+# The presence of an eval should turn cloneless anon subs into clonable
+# subs - otherwise the CvOUTSIDE of that sub may be wrong
+
+{
+ my %a;
+ for my $x (7,11) {
+ $a{$x} = sub { $x=$x; sub { eval '$x' } };
+ }
+ test { $a{7}->()->() + $a{11}->()->() == 18 };
+}
+
+require './test.pl'; # for runperl()
+
+{
+ # 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__';
+ print
+ sub {$_[0]->(@_)} -> (
+ sub {
+ $_[1]
+ ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->()
+ : "y"
+ },
+ 2
+ )
+ , "\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" };
+}
+
+# After newsub is redefined outside the BEGIN, it's 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';
+ }
+ test { $flag == 1 };
+}
+
+
+
+
+
+
projects / p5sagit/p5-mst-13.2.git / blobdiff