[p5sagit/p5-mst-13.2.git] / t / op / local.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    require './test.pl';
}
plan tests => 85;

sub foo {
    local($a, $b) = @_;
    local($c, $d);
    $c = "c 3";
    $d = "d 4";
    { local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); }
    is($a, "a 1");
    is($b, "b 2");
    $c, $d;
}

$a = "a 5";
$b = "b 6";
$c = "c 7";
$d = "d 8";

my @res;
@res =  &foo("a 1","b 2");
is($res[0], "c 3");
is($res[1], "d 4");

is($a, "a 5");
is($b, "b 6");
is($c, "c 7");
is($d, "d 8");
is($x, "a 9");
is($y, "c 10");

# same thing, only with arrays and associative arrays

sub foo2 {
    local($a, @b) = @_;
    local(@c, %d);
    @c = "c 3";
    $d{''} = "d 4";
    { local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); }
    is($a, "a 1");
    is("@b", "b 2");
    $c[0], $d{''};
}

$a = "a 5";
@b = "b 6";
@c = "c 7";
$d{''} = "d 8";

@res = &foo2("a 1","b 2");
is($res[0], "c 3");
is($res[1], "d 4");

is($a, "a 5");
is("@b", "b 6");
is($c[0], "c 7");
is($d{''}, "d 8");
is($x, "a 19");
is($y, "c 20");


eval 'local($$e)';
like($@, qr/Can't localize through a reference/);

eval '$e = []; local(@$e)';
like($@, qr/Can't localize through a reference/);

eval '$e = {}; local(%$e)';
like($@, qr/Can't localize through a reference/);

# Array and hash elements

@a = ('a', 'b', 'c');
{
    local($a[1]) = 'foo';
    local($a[2]) = $a[2];
    is($a[1], 'foo');
    is($a[2], 'c');
    undef @a;
}
is($a[1], 'b');
is($a[2], 'c');
ok(!defined $a[0]);

@a = ('a', 'b', 'c');
{
    local($a[1]) = "X";
    shift @a;
}
is($a[0].$a[1], "Xb");
{
    my $d = "@a";
    local @a = @a;
    is("@a", $d);
}

%h = ('a' => 1, 'b' => 2, 'c' => 3);
{
    local($h{'a'}) = 'foo';
    local($h{'b'}) = $h{'b'};
    is($h{'a'}, 'foo');
    is($h{'b'}, 2);
    local($h{'c'});
    delete $h{'c'};
}
is($h{'a'}, 1);
is($h{'b'}, 2);
{
    my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
    local %h = %h;
    is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
}
is($h{'c'}, 3);

# check for scope leakage
$a = 'outer';
if (1) { local $a = 'inner' }
is($a, 'outer');

# see if localization works when scope unwinds
local $m = 5;
eval {
    for $m (6) {
	local $m = 7;
	die "bye";
    }
};
is($m, 5);

# see if localization works on tied arrays
{
    package TA;
    sub TIEARRAY { bless [], $_[0] }
    sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] }
    sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v }
    sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
    sub FETCHSIZE { scalar(@{$_[0]}) }
    sub SHIFT { shift (@{$_[0]}) }
    sub EXTEND {}
}

tie @a, 'TA';
@a = ('a', 'b', 'c');
{
    local($a[1]) = 'foo';
    local($a[2]) = $a[2];
    is($a[1], 'foo');
    is($a[2], 'c');
    @a = ();
}
is($a[1], 'b');
is($a[2], 'c');
ok(!defined $a[0]);
{
    my $d = "@a";
    local @a = @a;
    is("@a", $d);
}

{
    package TH;
    sub TIEHASH { bless {}, $_[0] }
    sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] }
    sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v }
    sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
    sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
    sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
    sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} }
    sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} }
}

# see if localization works on tied hashes
tie %h, 'TH';
%h = ('a' => 1, 'b' => 2, 'c' => 3);

{
    local($h{'a'}) = 'foo';
    local($h{'b'}) = $h{'b'};
    local($h{'y'});
    local($h{'z'}) = 33;
    is($h{'a'}, 'foo');
    is($h{'b'}, 2);
    local($h{'c'});
    delete $h{'c'};
}
is($h{'a'}, 1);
is($h{'b'}, 2);
is($h{'c'}, 3);
# local() should preserve the existenceness of tied hash elements
ok(! exists $h{'y'});
ok(! exists $h{'z'});
TODO: {
    todo_skip("Localize entire tied hash");
    my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
    local %h = %h;
    is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
}

@a = ('a', 'b', 'c');
{
    local($a[1]) = "X";
    shift @a;
}
is($a[0].$a[1], "Xb");

# now try the same for %SIG

$SIG{TERM} = 'foo';
$SIG{INT} = \&foo;
$SIG{__WARN__} = $SIG{INT};
{
    local($SIG{TERM}) = $SIG{TERM};
    local($SIG{INT}) = $SIG{INT};
    local($SIG{__WARN__}) = $SIG{__WARN__};
    is($SIG{TERM}, 'main::foo');
    is($SIG{INT}, \&foo);
    is($SIG{__WARN__}, \&foo);
    local($SIG{INT});
    delete $SIG{__WARN__};
}
is($SIG{TERM}, 'main::foo');
is($SIG{INT}, \&foo);
is($SIG{__WARN__}, \&foo);
{
    my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG);
    local %SIG = %SIG;
    is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d);
}

# and for %ENV

$ENV{_X_} = 'a';
$ENV{_Y_} = 'b';
$ENV{_Z_} = 'c';
{
    local($ENV{_A_});
    local($ENV{_B_}) = 'foo';
    local($ENV{_X_}) = 'foo';
    local($ENV{_Y_}) = $ENV{_Y_};
    is($ENV{_X_}, 'foo');
    is($ENV{_Y_}, 'b');
    local($ENV{_Z_});
    delete $ENV{_Z_};
}
is($ENV{_X_}, 'a');
is($ENV{_Y_}, 'b');
is($ENV{_Z_}, 'c');
# local() should preserve the existenceness of %ENV elements
ok(! exists $ENV{_A_});
ok(! exists $ENV{_B_});
{
    my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV);
    local %ENV = %ENV;
    is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d);
}

# does implicit localization in foreach skip magic?

$_ = "o 0,o 1,";
my $iter = 0;
while (/(o.+?),/gc) {
    is($1, "o $iter");
    foreach (1..1) { $iter++ }
    if ($iter > 2) { fail("endless loop"); last; }
}

{
    package UnderScore;
    sub TIESCALAR { bless \my $self, shift }
    sub FETCH { die "read  \$_ forbidden" }
    sub STORE { die "write \$_ forbidden" }
    tie $_, __PACKAGE__;
    my @tests = (
	"Nesting"     => sub { print '#'; for (1..3) { print }
			       print "\n" },			1,
	"Reading"     => sub { print },				0,
	"Matching"    => sub { $x = /badness/ },		0,
	"Concat"      => sub { $_ .= "a" },			0,
	"Chop"        => sub { chop },				0,
	"Filetest"    => sub { -x },				0,
	"Assignment"  => sub { $_ = "Bad" },			0,
	# XXX whether next one should fail is debatable
	"Local \$_"   => sub { local $_  = 'ok?'; print },	0,
	"for local"   => sub { for("#ok?\n"){ print } },	1,
    );
    while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
	eval { &$code };
        main::ok(($ok xor $@), "Underscore '$name'");
    }
    untie $_;
}

{
    # BUG 20001205.22
    my %x;
    $x{a} = 1;
    { local $x{b} = 1; }
    ok(! exists $x{b});
    { local @x{c,d,e}; }
    ok(! exists $x{c});
}

# local() and readonly magic variables

eval { local $1 = 1 };
like($@, qr/Modification of a read-only value attempted/);

eval { for ($1) { local $_ = 1 } };
like($@, qr/Modification of a read-only value attempted/);

# make sure $1 is still read-only
eval { for ($1) { local $_ = 1 } };
like($@, qr/Modification of a read-only value attempted/);

# The s/// adds 'g' magic to $_, but it should remain non-readonly
eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
is($@, "");
Commit	Line	Data
a687059c	1	#!./perl
a687059c	2
d441d3db	3	BEGIN {
	4	chdir 't' if -d 't';
	5	require './test.pl';
	6	}
d60c5a05	7	plan tests => 85;
a687059c	8
	9	sub foo {
	10	local($a, $b) = @_;
	11	local($c, $d);
d441d3db	12	$c = "c 3";
	13	$d = "d 4";
	14	{ local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); }
	15	is($a, "a 1");
	16	is($b, "b 2");
	17	$c, $d;
a687059c	18	}
a687059c	19
d441d3db	20	$a = "a 5";
	21	$b = "b 6";
	22	$c = "c 7";
	23	$d = "d 8";
a687059c	24
d441d3db	25	my @res;
	26	@res = &foo("a 1","b 2");
	27	is($res[0], "c 3");
	28	is($res[1], "d 4");
a687059c	29
d441d3db	30	is($a, "a 5");
	31	is($b, "b 6");
	32	is($c, "c 7");
	33	is($d, "d 8");
	34	is($x, "a 9");
	35	is($y, "c 10");
a687059c	36
	37	# same thing, only with arrays and associative arrays
	38
	39	sub foo2 {
	40	local($a, @b) = @_;
	41	local(@c, %d);
d441d3db	42	@c = "c 3";
	43	$d{''} = "d 4";
	44	{ local($a,@c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); }
	45	is($a, "a 1");
	46	is("@b", "b 2");
	47	$c[0], $d{''};
a687059c	48	}
a687059c	49
d441d3db	50	$a = "a 5";
	51	@b = "b 6";
	52	@c = "c 7";
	53	$d{''} = "d 8";
	54
	55	@res = &foo2("a 1","b 2");
	56	is($res[0], "c 3");
	57	is($res[1], "d 4");
a687059c	58
d441d3db	59	is($a, "a 5");
	60	is("@b", "b 6");
	61	is($c[0], "c 7");
	62	is($d{''}, "d 8");
	63	is($x, "a 19");
	64	is($y, "c 20");
a687059c	65
706a304b	66
706a304b	67	eval 'local($$e)';
d441d3db	68	like($@, qr/Can't localize through a reference/);
706a304b	69
82d03984	70	eval '$e = []; local(@$e)';
d441d3db	71	like($@, qr/Can't localize through a reference/);
706a304b	72
82d03984	73	eval '$e = {}; local(%$e)';
d441d3db	74	like($@, qr/Can't localize through a reference/);
85aff577	75
161b7d16	76	# Array and hash elements
	77
	78	@a = ('a', 'b', 'c');
	79	{
	80	local($a[1]) = 'foo';
	81	local($a[2]) = $a[2];
d441d3db	82	is($a[1], 'foo');
d441d3db	83	is($a[2], 'c');
161b7d16	84	undef @a;
161b7d16	85	}
d441d3db	86	is($a[1], 'b');
	87	is($a[2], 'c');
	88	ok(!defined $a[0]);
161b7d16	89
	90	@a = ('a', 'b', 'c');
	91	{
	92	local($a[1]) = "X";
	93	shift @a;
	94	}
d441d3db	95	is($a[0].$a[1], "Xb");
d60c5a05	96	{
	97	my $d = "@a";
	98	local @a = @a;
	99	is("@a", $d);
	100	}
161b7d16	101
	102	%h = ('a' => 1, 'b' => 2, 'c' => 3);
	103	{
	104	local($h{'a'}) = 'foo';
	105	local($h{'b'}) = $h{'b'};
d441d3db	106	is($h{'a'}, 'foo');
d441d3db	107	is($h{'b'}, 2);
161b7d16	108	local($h{'c'});
	109	delete $h{'c'};
	110	}
d441d3db	111	is($h{'a'}, 1);
d441d3db	112	is($h{'b'}, 2);
d60c5a05	113	{
	114	my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
	115	local %h = %h;
	116	is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
	117	}
d441d3db	118	is($h{'c'}, 3);
2bb40b7f	119
	120	# check for scope leakage
	121	$a = 'outer';
	122	if (1) { local $a = 'inner' }
d441d3db	123	is($a, 'outer');
2bb40b7f	124
	125	# see if localization works when scope unwinds
	126	local $m = 5;
	127	eval {
	128	for $m (6) {
	129	local $m = 7;
	130	die "bye";
	131	}
	132	};
d441d3db	133	is($m, 5);
4e4c362e	134
	135	# see if localization works on tied arrays
	136	{
	137	package TA;
	138	sub TIEARRAY { bless [], $_[0] }
	139	sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] }
	140	sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v }
	141	sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
	142	sub FETCHSIZE { scalar(@{$_[0]}) }
	143	sub SHIFT { shift (@{$_[0]}) }
	144	sub EXTEND {}
	145	}
	146
	147	tie @a, 'TA';
	148	@a = ('a', 'b', 'c');
	149	{
	150	local($a[1]) = 'foo';
be6c24e0	151	local($a[2]) = $a[2];
d441d3db	152	is($a[1], 'foo');
d441d3db	153	is($a[2], 'c');
4e4c362e	154	@a = ();
4e4c362e	155	}
d441d3db	156	is($a[1], 'b');
	157	is($a[2], 'c');
	158	ok(!defined $a[0]);
d60c5a05	159	{
	160	my $d = "@a";
	161	local @a = @a;
	162	is("@a", $d);
	163	}
4e4c362e	164
	165	{
	166	package TH;
	167	sub TIEHASH { bless {}, $_[0] }
	168	sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] }
	169	sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v }
c39e6ab0	170	sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
4e4c362e	171	sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
4e4c362e	172	sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
d60c5a05	173	sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} }
d60c5a05	174	sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} }
4e4c362e	175	}
	176
	177	# see if localization works on tied hashes
	178	tie %h, 'TH';
	179	%h = ('a' => 1, 'b' => 2, 'c' => 3);
	180
	181	{
	182	local($h{'a'}) = 'foo';
be6c24e0	183	local($h{'b'}) = $h{'b'};
159ad915	184	local($h{'y'});
159ad915	185	local($h{'z'}) = 33;
d441d3db	186	is($h{'a'}, 'foo');
d441d3db	187	is($h{'b'}, 2);
4e4c362e	188	local($h{'c'});
	189	delete $h{'c'};
	190	}
d441d3db	191	is($h{'a'}, 1);
	192	is($h{'b'}, 2);
	193	is($h{'c'}, 3);
	194	# local() should preserve the existenceness of tied hash elements
	195	ok(! exists $h{'y'});
	196	ok(! exists $h{'z'});
d60c5a05	197	TODO: {
	198	todo_skip("Localize entire tied hash");
	199	my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
	200	local %h = %h;
	201	is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
	202	}
4e4c362e	203
	204	@a = ('a', 'b', 'c');
	205	{
	206	local($a[1]) = "X";
	207	shift @a;
	208	}
d441d3db	209	is($a[0].$a[1], "Xb");
4e4c362e	210
be6c24e0	211	# now try the same for %SIG
	212
	213	$SIG{TERM} = 'foo';
	214	$SIG{INT} = \&foo;
	215	$SIG{__WARN__} = $SIG{INT};
	216	{
	217	local($SIG{TERM}) = $SIG{TERM};
	218	local($SIG{INT}) = $SIG{INT};
	219	local($SIG{__WARN__}) = $SIG{__WARN__};
d441d3db	220	is($SIG{TERM}, 'main::foo');
	221	is($SIG{INT}, \&foo);
	222	is($SIG{__WARN__}, \&foo);
be6c24e0	223	local($SIG{INT});
	224	delete $SIG{__WARN__};
	225	}
d441d3db	226	is($SIG{TERM}, 'main::foo');
	227	is($SIG{INT}, \&foo);
	228	is($SIG{__WARN__}, \&foo);
d60c5a05	229	{
	230	my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG);
	231	local %SIG = %SIG;
	232	is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d);
	233	}
be6c24e0	234
	235	# and for %ENV
	236
	237	$ENV{_X_} = 'a';
	238	$ENV{_Y_} = 'b';
	239	$ENV{_Z_} = 'c';
	240	{
159ad915	241	local($ENV{_A_});
159ad915	242	local($ENV{_B_}) = 'foo';
be6c24e0	243	local($ENV{_X_}) = 'foo';
be6c24e0	244	local($ENV{_Y_}) = $ENV{_Y_};
d441d3db	245	is($ENV{_X_}, 'foo');
d441d3db	246	is($ENV{_Y_}, 'b');
be6c24e0	247	local($ENV{_Z_});
	248	delete $ENV{_Z_};
	249	}
d441d3db	250	is($ENV{_X_}, 'a');
	251	is($ENV{_Y_}, 'b');
	252	is($ENV{_Z_}, 'c');
	253	# local() should preserve the existenceness of %ENV elements
	254	ok(! exists $ENV{_A_});
	255	ok(! exists $ENV{_B_});
d60c5a05	256	{
	257	my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV);
	258	local %ENV = %ENV;
	259	is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d);
	260	}
be6c24e0	261
0214ae40	262	# does implicit localization in foreach skip magic?
0214ae40	263
d441d3db	264	$_ = "o 0,o 1,";
0214ae40	265	my $iter = 0;
0214ae40	266	while (/(o.+?),/gc) {
d441d3db	267	is($1, "o $iter");
0214ae40	268	foreach (1..1) { $iter++ }
d441d3db	269	if ($iter > 2) { fail("endless loop"); last; }
0214ae40	270	}
	271
	272	{
	273	package UnderScore;
	274	sub TIESCALAR { bless \my $self, shift }
	275	sub FETCH { die "read \$_ forbidden" }
	276	sub STORE { die "write \$_ forbidden" }
	277	tie $_, __PACKAGE__;
0214ae40	278	my @tests = (
	279	"Nesting" => sub { print '#'; for (1..3) { print }
	280	print "\n" }, 1,
	281	"Reading" => sub { print }, 0,
	282	"Matching" => sub { $x = /badness/ }, 0,
	283	"Concat" => sub { $_ .= "a" }, 0,
	284	"Chop" => sub { chop }, 0,
	285	"Filetest" => sub { -x }, 0,
	286	"Assignment" => sub { $_ = "Bad" }, 0,
	287	# XXX whether next one should fail is debatable
	288	"Local \$_" => sub { local $_ = 'ok?'; print }, 0,
	289	"for local" => sub { for("#ok?\n"){ print } }, 1,
	290	);
	291	while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
0214ae40	292	eval { &$code };
d441d3db	293	main::ok(($ok xor $@), "Underscore '$name'");
0214ae40	294	}
	295	untie $_;
	296	}
	297
1f5346dc	298	{
	299	# BUG 20001205.22
	300	my %x;
	301	$x{a} = 1;
	302	{ local $x{b} = 1; }
d441d3db	303	ok(! exists $x{b});
1f5346dc	304	{ local @x{c,d,e}; }
d441d3db	305	ok(! exists $x{c});
1f5346dc	306	}
159ad915	307
33f3c7b8	308	# local() and readonly magic variables
	309
	310	eval { local $1 = 1 };
d441d3db	311	like($@, qr/Modification of a read-only value attempted/);
33f3c7b8	312
33f3c7b8	313	eval { for ($1) { local $_ = 1 } };
d441d3db	314	like($@, qr/Modification of a read-only value attempted/);
33f3c7b8	315
0cbee0a4	316	# make sure $1 is still read-only
33f3c7b8	317	eval { for ($1) { local $_ = 1 } };
d441d3db	318	like($@, qr/Modification of a read-only value attempted/);
ac117f44	319
	320	# The s/// adds 'g' magic to $_, but it should remain non-readonly
	321	eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
d441d3db	322	is($@, "");