use strict;
use warnings;
#$Id: lexicals.t 26 2006-04-16 15:18:52Z demerphq $#
use Data::Dump::Streamer;
use Test::More tests => 14;
(my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/;
require $helper;
diag "\nPadWalker ",
eval "use PadWalker 0.99; 1" ? qq($PadWalker::VERSION is) : "isn't",
" installed";
$::No_Redump=$::No_Redump=1;
$::No_Dumper=$::No_Dumper=1;
{
my $v = 'foo';
my @v = ('f','o','o');
my $z = 1;
no warnings;
sub get_sub {
my @v=(@v,1);
my @y=('b','a','r');
my $x = join " ", @_, @v, $v, $z;
sub {
my @y = ( $x, "A".."G", @y);
my @v = ( "M".."R", @v);
my $x = join ":", @y, @v, $z||'undef';
$x . "!!";
},
sub { $x = shift; $z = shift if @_; },
do {
my @y=split //,'fuzz';
sub { return join "+",$z,$x,@y;}
},
}
}
{
my $expect;
if ( $] >= 5.013_001 ) {
$expect = <<'EXPECT';
my ($x,$z,@v,@y,@y_eclipse_1);
$x = 'f o o 1 foo 1';
$z = 1;
@v = (
'f',
( 'o' ) x 2,
1
);
@y = (
'b',
'a',
'r'
);
@y_eclipse_1 = (
'f',
'u',
( 'z' ) x 2
);
$CODE1 = sub {
my(@y) = ($x, ('A', 'B', 'C', 'D', 'E', 'F', 'G'), @y);
my(@v) = (('M', 'N', 'O', 'P', 'Q', 'R'), @v);
my $x = join(':', @y, @v, $z || 'undef');
$x . '!!';
};
$CODE2 = sub {
$x = shift();
$z = shift() if @_;
};
$CODE3 = sub {
return join('+', $z, $x, @y_eclipse_1);
};
EXPECT
}
else {
$expect = <<'EXPECT';
my ($x,$z,@v,@y,@y_eclipse_1);
$x = 'f o o 1 foo 1';
$z = 1;
@v = (
'f',
( 'o' ) x 2,
1
);
@y = (
'b',
'a',
'r'
);
@y_eclipse_1 = (
'f',
'u',
( 'z' ) x 2
);
$CODE1 = sub {
my(@y) = ($x, ('A', 'B', 'C', 'D', 'E', 'F', 'G'), @y);
my(@v) = (('M', 'N', 'O', 'P', 'Q', 'R'), @v);
my $x = join(':', @y, @v, $z || 'undef');
$x . '!!';
};
$CODE2 = sub {
$x = shift @_;
$z = shift @_ if @_;
};
$CODE3 = sub {
return join('+', $z, $x, @y_eclipse_1);
};
EXPECT
}
test_dump( 'Lexicals!!', scalar(Dump()), ( get_sub() ), $expect);
}
{
# local $Data::Dump::Streamer::DEBUG=1;
my $x;
$x = sub { $x };
test_dump( "Self-referential", scalar(Dump()),( $x ), <<'EXPECT');
$x = sub {
$x;
};
EXPECT
}
{
my $a;
my $b = sub { $a };
test_dump( "Nested closure with shared state", scalar(Dump()),
( sub { $a, $b } ), <<'EXPECT');
my ($a,$b);
$a = undef;
$b = sub {
$a;
};
$CODE1 = sub {
$a, $b;
};
EXPECT
}
{
my $a;
my $b;
my $z = sub { $a, $b };
my $y = do { my $b; sub { $a, $b } };
test_dump( "Overlapping declarations", scalar(Dump()),
( $y, $z ), <<'EXPECT');
my ($a,$b,$b_eclipse_1);
$a = undef;
$b = undef;
$b_eclipse_1 = undef;
$CODE1 = sub {
$a, $b;
};
$CODE2 = sub {
$a, $b_eclipse_1;
};
EXPECT
}
{
my $a;
my $z = sub { $a };
my $b;
my $y = sub { $a, $b };
test_dump( "Overlapping declarations two", scalar(Dump()),
( $y, $z ), <<'EXPECT');
my ($a,$b);
$a = undef;
$b = undef;
$CODE1 = sub {
$a, $b;
};
$CODE2 = sub {
$a;
};
EXPECT
}
{
my $z = do {
my $a;
sub { $a };
};
my $y = do {
my $a;
sub { $a };
};
test_dump( "Unrelated environments", scalar(Dump()),
( $z, $y ), <<'EXPECT');
my ($a,$a_eclipse_1);
$a = undef;
$a_eclipse_1 = undef;
$CODE1 = sub {
$a;
};
$CODE2 = sub {
$a_eclipse_1;
};
EXPECT
}
{
my $bad = \&Not::Implemented;
test_dump( "Unimplemented code", scalar(Dump()), ( $bad ), <<'EXPECT');
$CODE1 = \&Not::Implemented;
EXPECT
}
{
my $a;
my $z = sub { $a };
test_dump( "Shared state/enclosed", scalar(Dump()), ( $z, sub { $a, $z } ),
<<'EXPECT');
my ($a);
$a = undef;
$z = sub {
$a;
};
$CODE1 = sub {
$a, $z;
};
EXPECT
test_dump( "Named Shared state/enclosed", scalar(Dump())->Names('foo','bar'),
( $z, sub { $a, $z } ),
<<'EXPECT');
my ($a);
$a = undef;
$foo = sub {
$a;
};
$bar = sub {
$a, $foo;
};
EXPECT
}
{
no warnings;
our $b;
my $a;
my $b = sub { $b };
test_dump( "sub b", scalar(Dump()), ( $b ), <<'EXPECT');
$CODE1 = sub {
$b;
};
EXPECT
test_dump( "double sub b", scalar(Dump()), ( sub { $b } ), <<'EXPECT');
my ($b);
$b = sub {
$b;
};
$CODE1 = sub {
$b;
};
EXPECT
}
{
my $a = "foo";
my $x = sub { return $a . "bar" };
sub f { print $x->() }
test_dump( "recursively nested subs", scalar(Dump()), ( \&f ), <<'EXPECT');
my ($a,$x);
$a = 'foo';
$x = sub {
return $a . 'bar';
};
$CODE1 = sub {
print &$x();
};
EXPECT
}
{
test_dump( "EclipseName", Dump->EclipseName('%d_foiled_%s'),
( [
map {
my $x;
my $x_eclipse_1;
sub {$x}, sub {$x_eclipse_1};
} 1, 2
] ), <<'EXPECT');
my ($1_foiled_x,$1_foiled_x_eclipse_1,$x,$x_eclipse_1);
$1_foiled_x = undef;
$1_foiled_x_eclipse_1 = undef;
$x = undef;
$x_eclipse_1 = undef;
$ARRAY1 = [
sub {
$x;
},
sub {
$x_eclipse_1;
},
sub {
$1_foiled_x;
},
sub {
$1_foiled_x_eclipse_1;
}
];
EXPECT
}
{
test_dump( "EclipseName 2", Dump->EclipseName('%s_muhaha_%d'),
( [
map {
my $x;
my $x_eclipse_1;
sub {$x}, sub {$x_eclipse_1};
} 1, 2
] ), <<'EXPECT');
my ($x,$x_eclipse_1,$x_eclipse_1_muhaha_1,$x_muhaha_1);
$x = undef;
$x_eclipse_1 = undef;
$x_eclipse_1_muhaha_1 = undef;
$x_muhaha_1 = undef;
$ARRAY1 = [
sub {
$x;
},
sub {
$x_eclipse_1;
},
sub {
$x_muhaha_1;
},
sub {
$x_eclipse_1_muhaha_1;
}
];
EXPECT
}
if (0){
#no warnings;
my @close;
my ($x,$y)=(3.141,5);
for my $a ($x, $y) {
for my $b ($x, $y) {
push @close, sub { ++$a, ++$b; return } if \$a != \$b
}
}
my $out=Dump(\@close)->Out();
print $out;
#print B::Deparse::WARN_MASK;
}
__END__