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

#!./perl

# Add new tests to the end with format:
# ########
#
# # test description
# Test code
# EXPECT
# Warn or die msgs (if any) at - line 1234
#

chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = "../lib";

$|=1;

undef $/;
@prgs = split /^########\n/m, <DATA>;

require './test.pl';
plan(tests => scalar @prgs);
for (@prgs){
    ++$i;
    my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
    print("not ok $i # bad test format\n"), next
        unless defined $expected;
    my ($testname) = $prog =~ /^# (.*)\n/m;
    $testname ||= '';
    $TODO = $testname =~ s/^TODO //;
    $results =~ s/\n+$//;
    $expected =~ s/\n+$//;

    fresh_perl_is($prog, $expected, {}, $testname);
}

__END__

# standard behaviour, without any extra references
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
EXPECT
########

# standard behaviour, without any extra references
use Tie::Hash ;
{package Tie::HashUntie;
 use base 'Tie::StdHash';
 sub UNTIE
  {
   warn "Untied\n";
  }
}
tie %h, Tie::HashUntie;
untie %h;
EXPECT
Untied
########

# standard behaviour, with 1 extra reference
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
EXPECT
########

# standard behaviour, with 1 extra reference via tied
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
untie %h;
EXPECT
########

# standard behaviour, with 1 extra reference which is destroyed
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
untie %h;
EXPECT
########

# standard behaviour, with 1 extra reference via tied which is destroyed
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
$a = 0 ;
untie %h;
EXPECT
########

# strict behaviour, without any extra references
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
EXPECT
########

# strict behaviour, with 1 extra references generating an error
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
EXPECT
untie attempted while 1 inner references still exist at - line 6.
########

# strict behaviour, with 1 extra references via tied generating an error
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
untie %h;
EXPECT
untie attempted while 1 inner references still exist at - line 7.
########

# strict behaviour, with 1 extra references which are destroyed
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
untie %h;
EXPECT
########

# strict behaviour, with extra 1 references via tied which are destroyed
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
$a = 0 ;
untie %h;
EXPECT
########

# strict error behaviour, with 2 extra references
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
untie %h;
EXPECT
untie attempted while 2 inner references still exist at - line 7.
########

# strict behaviour, check scope of strictness.
no warnings 'untie';
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
    use warnings 'untie';
    use Tie::Hash ;
    tie %h, Tie::StdHash;
    untie %h;
}
untie %H;
EXPECT
########

# Forbidden aggregate self-ties
sub Self::TIEHASH { bless $_[1], $_[0] }
{
    my %c;
    tie %c, 'Self', \%c;
}
EXPECT
Self-ties of arrays and hashes are not supported at - line 6.
########

# Allowed scalar self-ties
my $destroyed = 0;
sub Self::TIESCALAR { bless $_[1], $_[0] }
sub Self::DESTROY   { $destroyed = 1; }
{
    my $c = 42;
    tie $c, 'Self', \$c;
}
die "self-tied scalar not DESTROYed" unless $destroyed == 1;
EXPECT
########

# Allowed glob self-ties
my $destroyed = 0;
my $printed   = 0;
sub Self2::TIEHANDLE { bless $_[1], $_[0] }
sub Self2::DESTROY   { $destroyed = 1; }
sub Self2::PRINT     { $printed = 1; }
{
    use Symbol;
    my $c = gensym;
    tie *$c, 'Self2', $c;
    print $c 'Hello';
}
die "self-tied glob not PRINTed" unless $printed == 1;
die "self-tied glob not DESTROYed" unless $destroyed == 1;
EXPECT
########

# Allowed IO self-ties
my $destroyed = 0;
sub Self3::TIEHANDLE { bless $_[1], $_[0] }
sub Self3::DESTROY   { $destroyed = 1; }
sub Self3::PRINT     { $printed = 1; }
{
    use Symbol 'geniosym';
    my $c = geniosym;
    tie *$c, 'Self3', $c;
    print $c 'Hello';
}
die "self-tied IO not PRINTed" unless $printed == 1;
die "self-tied IO not DESTROYed" unless $destroyed == 1;
EXPECT
########

# TODO IO "self-tie" via TEMP glob
my $destroyed = 0;
sub Self3::TIEHANDLE { bless $_[1], $_[0] }
sub Self3::DESTROY   { $destroyed = 1; }
sub Self3::PRINT     { $printed = 1; }
{
    use Symbol 'geniosym';
    my $c = geniosym;
    tie *$c, 'Self3', \*$c;
    print $c 'Hello';
}
die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
EXPECT
########

# Interaction of tie and vec

my ($a, $b);
use Tie::Scalar;
tie $a,Tie::StdScalar or die;
vec($b,1,1)=1;
$a = $b;
vec($a,1,1)=0;
vec($b,1,1)=0;
die unless $a eq $b;
EXPECT
########

# correct unlocalisation of tied hashes (patch #16431)
use Tie::Hash ;
tie %tied, Tie::StdHash;
{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
{ local $ENV{'foo'}  } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
EXPECT
########

# An attempt at lvalueable barewords broke this
tie FH, 'main';
EXPECT
Can't modify constant item in tie at - line 3, near "'main';"
Execution of - aborted due to compilation errors.
########

# localizing tied hash slices
$ENV{FooA} = 1;
$ENV{FooB} = 2;
print exists $ENV{FooA} ? 1 : 0, "\n";
print exists $ENV{FooB} ? 2 : 0, "\n";
print exists $ENV{FooC} ? 3 : 0, "\n";
{
    local @ENV{qw(FooA FooC)};
    print exists $ENV{FooA} ? 4 : 0, "\n";
    print exists $ENV{FooB} ? 5 : 0, "\n";
    print exists $ENV{FooC} ? 6 : 0, "\n";
}
print exists $ENV{FooA} ? 7 : 0, "\n";
print exists $ENV{FooB} ? 8 : 0, "\n";
print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
EXPECT
1
2
0
4
5
6
7
8
0
########
#
# FETCH freeing tie'd SV
sub TIESCALAR { bless [] }
sub FETCH { *a = \1; 1 }
tie $a, 'main';
print $a;
EXPECT
########

#  [20020716.007] - nested FETCHES

sub F1::TIEARRAY { bless [], 'F1' }
sub F1::FETCH { 1 }
my @f1;
tie @f1, 'F1';

sub F2::TIEARRAY { bless [2], 'F2' }
sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
my @f2;
tie @f2, 'F2';

print $f2[4][0],"\n";

sub F3::TIEHASH { bless [], 'F3' }
sub F3::FETCH { 1 }
my %f3;
tie %f3, 'F3';

sub F4::TIEHASH { bless [3], 'F4' }
sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
my %f4;
tie %f4, 'F4';

print $f4{'foo'}[0],"\n";

EXPECT
2
3
########
# test untie() from within FETCH
package Foo;
sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
sub FETCH {
  my $self = shift;
  my ($obj, $field) = @$self;
  untie $obj->{$field};
  $obj->{$field} = "Bar";
}
package main;
tie $a->{foo}, "Foo", $a, "foo";
$a->{foo}; # access once
# the hash element should not be tied anymore
print defined tied $a->{foo} ? "not ok" : "ok";
EXPECT
ok
########
# the tmps returned by FETCH should appear to be SCALAR
# (even though they are now implemented using PVLVs.)
package X;
sub TIEHASH { bless {} }
sub TIEARRAY { bless {} }
sub FETCH {1}
my (%h, @a);
tie %h, 'X';
tie @a, 'X';
my $r1 = \$h{1};
my $r2 = \$a[0];
my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
$s=~ s/\(0x\w+\)//g;
print $s, "\n";
EXPECT
SCALAR SCALAR SCALAR SCALAR
########
# [perl #23287] segfault in untie
sub TIESCALAR { bless $_[1], $_[0] }
my $var;
tie $var, 'main', \$var;
untie $var;
EXPECT
########
# Test case from perlmonks by runrig
# http://www.perlmonks.org/index.pl?node_id=273490
# "Here is what I tried. I think its similar to what you've tried
#  above. Its odd but convienient that after untie'ing you are left with
#  a variable that has the same value as was last returned from
#  FETCH. (At least on my perl v5.6.1). So you don't need to pass a
#  reference to the variable in order to set it after the untie (here it
#  is accessed through a closure)."
use strict;
use warnings;
package MyTied;
sub TIESCALAR {
    my ($class,$code) = @_;
    bless $code, $class;
}
sub FETCH {
    my $self = shift;
    print "Untie\n";
    $self->();
}
package main;
my $var;
tie $var, 'MyTied', sub { untie $var; 4 };
print "One\n";
print "$var\n";
print "Two\n";
print "$var\n";
print "Three\n";
print "$var\n";
EXPECT
One
Untie
4
Two
4
Three
4
########
# [perl #22297] cannot untie scalar from within tied FETCH
my $counter = 0;
my $x = 7;
my $ref = \$x;
tie $x, 'Overlay', $ref, $x;
my $y;
$y = $x;
$y = $x;
$y = $x;
$y = $x;
#print "WILL EXTERNAL UNTIE $ref\n";
untie $$ref;
$y = $x;
$y = $x;
$y = $x;
$y = $x;
#print "counter = $counter\n";

print (($counter == 1) ? "ok\n" : "not ok\n");

package Overlay;

sub TIESCALAR
{
        my $pkg = shift;
        my ($ref, $val) = @_;
        return bless [ $ref, $val ], $pkg;
}

sub FETCH
{
        my $self = shift;
        my ($ref, $val) = @$self;
        #print "WILL INTERNAL UNITE $ref\n";
        $counter++;
        untie $$ref;
        return $val;
}
EXPECT
ok
########

# TODO [perl #948] cannot meaningfully tie $,
package TieDollarComma;

sub TIESCALAR {
     my $pkg = shift;
     return bless \my $x, $pkg;
}

sub STORE {
    my $self = shift;
    $$self = shift;
    print "STORE set '$$self'\n";
}

sub FETCH {
    my $self = shift;
    print "FETCH\n";
    return $$self;
}
package main;

tie $,, 'TieDollarComma';
$, = 'BOBBINS';
print "join", "things", "up\n";
EXPECT
STORE set 'BOBBINS'
FETCH
FETCH
joinBOBBINSthingsBOBBINSup
########

# test SCALAR method
package TieScalar;

sub TIEHASH {
    my $pkg = shift;
    bless { } => $pkg;
}

sub STORE {
    $_[0]->{$_[1]} = $_[2];
}

sub FETCH {
    $_[0]->{$_[1]}
}

sub CLEAR {
    %{ $_[0] } = ();
}

sub SCALAR {
    print "SCALAR\n";
    return 0 if ! keys %{$_[0]};
    sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
}

package main;
tie my %h => "TieScalar";
$h{key1} = "val1";
$h{key2} = "val2";
print scalar %h, "\n";
%h = ();
print scalar %h, "\n";
EXPECT
SCALAR
2/2
SCALAR
0
########

# test scalar on tied hash when no SCALAR method has been given
package TieScalar;

sub TIEHASH {
    my $pkg = shift;
    bless { } => $pkg;
}
sub STORE {
    $_[0]->{$_[1]} = $_[2];
}
sub FETCH {
    $_[0]->{$_[1]}
}
sub CLEAR {
    %{ $_[0] } = ();
}
sub FIRSTKEY {
    my $a = keys %{ $_[0] };
    print "FIRSTKEY\n";
    each %{ $_[0] };
}

package main;
tie my %h => "TieScalar";

if (!%h) {
    print "empty\n";
} else {
    print "not empty\n";
}

$h{key1} = "val1";
print "not empty\n" if %h;
print "not empty\n" if %h;
print "-->\n";
my ($k,$v) = each %h;
print "<--\n";
print "not empty\n" if %h;
%h = ();
print "empty\n" if ! %h;
EXPECT
FIRSTKEY
empty
FIRSTKEY
not empty
FIRSTKEY
not empty
-->
FIRSTKEY
<--
not empty
FIRSTKEY
empty
########
sub TIESCALAR { bless {} }
sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
tie $h, "main";
print $h,"\n";
EXPECT
3.3
########
sub TIESCALAR { bless {} }
sub FETCH { shift()->{i} ++ }
tie $h, "main";
print $h.$h;
EXPECT
01
########
sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
sub FETCH { ${$_[0]} }
tie my $x, "main", 2;
tie my $y, "main", 8;
print $x | $y;
EXPECT
10
########
# Bug 36267
sub TIEHASH  { bless {}, $_[0] }
sub STORE    { $_[0]->{$_[1]} = $_[2] }
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY  { each %{$_[0]} }
sub DELETE   { delete $_[0]->{$_[1]} }
sub CLEAR    { %{$_[0]} = () }
$h{b}=1;
delete $h{b};
print scalar keys %h, "\n";
tie %h, 'main';
$i{a}=1;
%h = %i;
untie %h;
print scalar keys %h, "\n";
EXPECT
0
0
########
# Bug 37731
sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
sub foo::FETCH { $_[0]->{value} }
tie my $VAR, 'foo', '42';
foreach my $var ($VAR) {
    print +($var eq $VAR) ? "yes\n" : "no\n";
}
EXPECT
yes
Commit	Line	Data
49d42823	1	#!./perl
49d42823	2
d87ebaca	3	# Add new tests to the end with format:
	4	# ########
	5	#
	6	# # test description
	7	# Test code
	8	# EXPECT
	9	# Warn or die msgs (if any) at - line 1234
	10	#
49d42823	11
49d42823	12	chdir 't' if -d 't';
20822f61	13	@INC = '../lib';
49d42823	14	$ENV{PERL5LIB} = "../lib";
	15
	16	$\|=1;
	17
	18	undef $/;
d87ebaca	19	@prgs = split /^########\n/m, <DATA>;
49d42823	20
d87ebaca	21	require './test.pl';
d87ebaca	22	plan(tests => scalar @prgs);
49d42823	23	for (@prgs){
d87ebaca	24	++$i;
	25	my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
	26	print("not ok $i # bad test format\n"), next
	27	unless defined $expected;
	28	my ($testname) = $prog =~ /^# (.*)\n/m;
	29	$testname \|\|= '';
	30	$TODO = $testname =~ s/^TODO //;
49d42823	31	$results =~ s/\n+$//;
49d42823	32	$expected =~ s/\n+$//;
d87ebaca	33
d87ebaca	34	fresh_perl_is($prog, $expected, {}, $testname);
49d42823	35	}
	36
	37	__END__
	38
	39	# standard behaviour, without any extra references
	40	use Tie::Hash ;
	41	tie %h, Tie::StdHash;
	42	untie %h;
	43	EXPECT
	44	########
	45
a29a5827	46	# standard behaviour, without any extra references
	47	use Tie::Hash ;
	48	{package Tie::HashUntie;
	49	use base 'Tie::StdHash';
	50	sub UNTIE
	51	{
	52	warn "Untied\n";
	53	}
	54	}
	55	tie %h, Tie::HashUntie;
	56	untie %h;
	57	EXPECT
	58	Untied
	59	########
	60
49d42823	61	# standard behaviour, with 1 extra reference
	62	use Tie::Hash ;
	63	$a = tie %h, Tie::StdHash;
	64	untie %h;
	65	EXPECT
	66	########
	67
	68	# standard behaviour, with 1 extra reference via tied
	69	use Tie::Hash ;
	70	tie %h, Tie::StdHash;
	71	$a = tied %h;
	72	untie %h;
	73	EXPECT
	74	########
	75
	76	# standard behaviour, with 1 extra reference which is destroyed
	77	use Tie::Hash ;
	78	$a = tie %h, Tie::StdHash;
	79	$a = 0 ;
	80	untie %h;
	81	EXPECT
	82	########
	83
	84	# standard behaviour, with 1 extra reference via tied which is destroyed
	85	use Tie::Hash ;
	86	tie %h, Tie::StdHash;
	87	$a = tied %h;
	88	$a = 0 ;
	89	untie %h;
	90	EXPECT
	91	########
	92
	93	# strict behaviour, without any extra references
4438c4b7	94	use warnings 'untie';
49d42823	95	use Tie::Hash ;
	96	tie %h, Tie::StdHash;
	97	untie %h;
	98	EXPECT
	99	########
	100
	101	# strict behaviour, with 1 extra references generating an error
4438c4b7	102	use warnings 'untie';
49d42823	103	use Tie::Hash ;
	104	$a = tie %h, Tie::StdHash;
	105	untie %h;
	106	EXPECT
d87ebaca	107	untie attempted while 1 inner references still exist at - line 6.
49d42823	108	########
	109
	110	# strict behaviour, with 1 extra references via tied generating an error
4438c4b7	111	use warnings 'untie';
49d42823	112	use Tie::Hash ;
	113	tie %h, Tie::StdHash;
	114	$a = tied %h;
	115	untie %h;
	116	EXPECT
d87ebaca	117	untie attempted while 1 inner references still exist at - line 7.
49d42823	118	########
	119
	120	# strict behaviour, with 1 extra references which are destroyed
4438c4b7	121	use warnings 'untie';
49d42823	122	use Tie::Hash ;
	123	$a = tie %h, Tie::StdHash;
	124	$a = 0 ;
	125	untie %h;
	126	EXPECT
	127	########
	128
	129	# strict behaviour, with extra 1 references via tied which are destroyed
4438c4b7	130	use warnings 'untie';
49d42823	131	use Tie::Hash ;
	132	tie %h, Tie::StdHash;
	133	$a = tied %h;
	134	$a = 0 ;
	135	untie %h;
	136	EXPECT
	137	########
	138
87f0b213	139	# strict error behaviour, with 2 extra references
4438c4b7	140	use warnings 'untie';
49d42823	141	use Tie::Hash ;
	142	$a = tie %h, Tie::StdHash;
	143	$b = tied %h ;
	144	untie %h;
	145	EXPECT
d87ebaca	146	untie attempted while 2 inner references still exist at - line 7.
49d42823	147	########
	148
	149	# strict behaviour, check scope of strictness.
4438c4b7	150	no warnings 'untie';
49d42823	151	use Tie::Hash ;
	152	$A = tie %H, Tie::StdHash;
	153	$C = $B = tied %H ;
	154	{
4438c4b7	155	use warnings 'untie';
49d42823	156	use Tie::Hash ;
	157	tie %h, Tie::StdHash;
	158	untie %h;
	159	}
	160	untie %H;
	161	EXPECT
33c27489	162	########
d87ebaca	163
ae21d580	164	# Forbidden aggregate self-ties
33c27489	165	sub Self::TIEHASH { bless $_[1], $_[0] }
ae21d580	166	{
d87ebaca	167	my %c;
ae21d580	168	tie %c, 'Self', \%c;
	169	}
	170	EXPECT
d87ebaca	171	Self-ties of arrays and hashes are not supported at - line 6.
ae21d580	172	########
d87ebaca	173
ae21d580	174	# Allowed scalar self-ties
d87ebaca	175	my $destroyed = 0;
ae21d580	176	sub Self::TIESCALAR { bless $_[1], $_[0] }
d87ebaca	177	sub Self::DESTROY { $destroyed = 1; }
33c27489	178	{
ae21d580	179	my $c = 42;
ae21d580	180	tie $c, 'Self', \$c;
33c27489	181	}
d87ebaca	182	die "self-tied scalar not DESTROYed" unless $destroyed == 1;
7bb043c3	183	EXPECT
83f527ec	184	########
3ca7705e	185
b5ccf5f2	186	# Allowed glob self-ties
87f0b213	187	my $destroyed = 0;
	188	my $printed = 0;
	189	sub Self2::TIEHANDLE { bless $_[1], $_[0] }
	190	sub Self2::DESTROY { $destroyed = 1; }
	191	sub Self2::PRINT { $printed = 1; }
	192	{
	193	use Symbol;
	194	my $c = gensym;
	195	tie *$c, 'Self2', $c;
	196	print $c 'Hello';
	197	}
	198	die "self-tied glob not PRINTed" unless $printed == 1;
43bb546a	199	die "self-tied glob not DESTROYed" unless $destroyed == 1;
87f0b213	200	EXPECT
	201	########
	202
	203	# Allowed IO self-ties
	204	my $destroyed = 0;
	205	sub Self3::TIEHANDLE { bless $_[1], $_[0] }
	206	sub Self3::DESTROY { $destroyed = 1; }
b5ccf5f2	207	sub Self3::PRINT { $printed = 1; }
87f0b213	208	{
	209	use Symbol 'geniosym';
	210	my $c = geniosym;
	211	tie *$c, 'Self3', $c;
b5ccf5f2	212	print $c 'Hello';
87f0b213	213	}
b5ccf5f2	214	die "self-tied IO not PRINTed" unless $printed == 1;
43bb546a	215	die "self-tied IO not DESTROYed" unless $destroyed == 1;
87f0b213	216	EXPECT
87f0b213	217	########
0b2c215a	218
b5ccf5f2	219	# TODO IO "self-tie" via TEMP glob
	220	my $destroyed = 0;
	221	sub Self3::TIEHANDLE { bless $_[1], $_[0] }
	222	sub Self3::DESTROY { $destroyed = 1; }
	223	sub Self3::PRINT { $printed = 1; }
	224	{
	225	use Symbol 'geniosym';
	226	my $c = geniosym;
	227	tie $c, 'Self3', \$c;
	228	print $c 'Hello';
	229	}
	230	die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
	231	die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
	232	EXPECT
	233	########
	234
d87ebaca	235	# Interaction of tie and vec
	236
	237	my ($a, $b);
	238	use Tie::Scalar;
	239	tie $a,Tie::StdScalar or die;
	240	vec($b,1,1)=1;
	241	$a = $b;
	242	vec($a,1,1)=0;
	243	vec($b,1,1)=0;
	244	die unless $a eq $b;
	245	EXPECT
	246	########
	247
	248	# correct unlocalisation of tied hashes (patch #16431)
	249	use Tie::Hash ;
	250	tie %tied, Tie::StdHash;
	251	{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
	252	{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
	253	{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
	254	EXPECT
	255	########
	256
	257	# An attempt at lvalueable barewords broke this
	258	tie FH, 'main';
	259	EXPECT
	260	Can't modify constant item in tie at - line 3, near "'main';"
	261	Execution of - aborted due to compilation errors.
eb85dfd3	262	########
	263
	264	# localizing tied hash slices
	265	$ENV{FooA} = 1;
	266	$ENV{FooB} = 2;
	267	print exists $ENV{FooA} ? 1 : 0, "\n";
	268	print exists $ENV{FooB} ? 2 : 0, "\n";
	269	print exists $ENV{FooC} ? 3 : 0, "\n";
	270	{
	271	local @ENV{qw(FooA FooC)};
	272	print exists $ENV{FooA} ? 4 : 0, "\n";
	273	print exists $ENV{FooB} ? 5 : 0, "\n";
	274	print exists $ENV{FooC} ? 6 : 0, "\n";
	275	}
	276	print exists $ENV{FooA} ? 7 : 0, "\n";
	277	print exists $ENV{FooB} ? 8 : 0, "\n";
	278	print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
	279	EXPECT
	280	1
	281	2
	282	0
	283	4
	284	5
	285	6
	286	7
	287	8
	288	0
b77f7d40	289	########
	290	#
	291	# FETCH freeing tie'd SV
	292	sub TIESCALAR { bless [] }
	293	sub FETCH { *a = \1; 1 }
	294	tie $a, 'main';
	295	print $a;
	296	EXPECT
dd28f7bb	297	########
	298
	299	# [20020716.007] - nested FETCHES
	300
	301	sub F1::TIEARRAY { bless [], 'F1' }
	302	sub F1::FETCH { 1 }
	303	my @f1;
	304	tie @f1, 'F1';
	305
	306	sub F2::TIEARRAY { bless [2], 'F2' }
	307	sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
	308	my @f2;
	309	tie @f2, 'F2';
	310
	311	print $f2[4][0],"\n";
	312
	313	sub F3::TIEHASH { bless [], 'F3' }
	314	sub F3::FETCH { 1 }
	315	my %f3;
	316	tie %f3, 'F3';
	317
	318	sub F4::TIEHASH { bless [3], 'F4' }
	319	sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
	320	my %f4;
	321	tie %f4, 'F4';
	322
	323	print $f4{'foo'}[0],"\n";
	324
	325	EXPECT
	326	2
	327	3
38193a09	328	########
	329	# test untie() from within FETCH
	330	package Foo;
	331	sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
	332	sub FETCH {
	333	my $self = shift;
	334	my ($obj, $field) = @$self;
	335	untie $obj->{$field};
	336	$obj->{$field} = "Bar";
	337	}
	338	package main;
	339	tie $a->{foo}, "Foo", $a, "foo";
	340	$a->{foo}; # access once
	341	# the hash element should not be tied anymore
	342	print defined tied $a->{foo} ? "not ok" : "ok";
	343	EXPECT
	344	ok
be65207d	345	########
	346	# the tmps returned by FETCH should appear to be SCALAR
	347	# (even though they are now implemented using PVLVs.)
	348	package X;
	349	sub TIEHASH { bless {} }
	350	sub TIEARRAY { bless {} }
	351	sub FETCH {1}
	352	my (%h, @a);
	353	tie %h, 'X';
	354	tie @a, 'X';
	355	my $r1 = \$h{1};
	356	my $r2 = \$a[0];
	357	my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
	358	$s=~ s/\(0x\w+\)//g;
	359	print $s, "\n";
	360	EXPECT
	361	SCALAR SCALAR SCALAR SCALAR
b7056d9c	362	########
	363	# [perl #23287] segfault in untie
	364	sub TIESCALAR { bless $_[1], $_[0] }
	365	my $var;
	366	tie $var, 'main', \$var;
	367	untie $var;
	368	EXPECT
16e0ce55	369	########
	370	# Test case from perlmonks by runrig
	371	# http://www.perlmonks.org/index.pl?node_id=273490
	372	# "Here is what I tried. I think its similar to what you've tried
	373	# above. Its odd but convienient that after untie'ing you are left with
	374	# a variable that has the same value as was last returned from
	375	# FETCH. (At least on my perl v5.6.1). So you don't need to pass a
	376	# reference to the variable in order to set it after the untie (here it
	377	# is accessed through a closure)."
	378	use strict;
	379	use warnings;
	380	package MyTied;
	381	sub TIESCALAR {
	382	my ($class,$code) = @_;
	383	bless $code, $class;
	384	}
	385	sub FETCH {
	386	my $self = shift;
	387	print "Untie\n";
	388	$self->();
	389	}
	390	package main;
	391	my $var;
	392	tie $var, 'MyTied', sub { untie $var; 4 };
	393	print "One\n";
	394	print "$var\n";
	395	print "Two\n";
	396	print "$var\n";
	397	print "Three\n";
	398	print "$var\n";
	399	EXPECT
	400	One
	401	Untie
	402	4
	403	Two
	404	4
	405	Three
	406	4
dd12389b	407	########
	408	# [perl #22297] cannot untie scalar from within tied FETCH
	409	my $counter = 0;
	410	my $x = 7;
	411	my $ref = \$x;
	412	tie $x, 'Overlay', $ref, $x;
	413	my $y;
	414	$y = $x;
	415	$y = $x;
	416	$y = $x;
	417	$y = $x;
	418	#print "WILL EXTERNAL UNTIE $ref\n";
	419	untie $$ref;
	420	$y = $x;
	421	$y = $x;
	422	$y = $x;
	423	$y = $x;
	424	#print "counter = $counter\n";
	425
	426	print (($counter == 1) ? "ok\n" : "not ok\n");
	427
	428	package Overlay;
	429
	430	sub TIESCALAR
	431	{
	432	my $pkg = shift;
	433	my ($ref, $val) = @_;
	434	return bless [ $ref, $val ], $pkg;
	435	}
	436
	437	sub FETCH
	438	{
	439	my $self = shift;
	440	my ($ref, $val) = @$self;
	441	#print "WILL INTERNAL UNITE $ref\n";
	442	$counter++;
	443	untie $$ref;
	444	return $val;
	445	}
	446	EXPECT
	447	ok
6c0731c3	448	########
	449
	450	# TODO [perl #948] cannot meaningfully tie $,
	451	package TieDollarComma;
	452
	453	sub TIESCALAR {
	454	my $pkg = shift;
	455	return bless \my $x, $pkg;
	456	}
	457
	458	sub STORE {
	459	my $self = shift;
	460	$$self = shift;
	461	print "STORE set '$$self'\n";
	462	}
	463
	464	sub FETCH {
	465	my $self = shift;
	466	print "FETCH\n";
	467	return $$self;
	468	}
	469	package main;
	470
	471	tie $,, 'TieDollarComma';
	472	$, = 'BOBBINS';
	473	print "join", "things", "up\n";
	474	EXPECT
	475	STORE set 'BOBBINS'
	476	FETCH
	477	FETCH
	478	joinBOBBINSthingsBOBBINSup
a3bcc51e	479	########
	480
	481	# test SCALAR method
	482	package TieScalar;
	483
	484	sub TIEHASH {
	485	my $pkg = shift;
	486	bless { } => $pkg;
	487	}
	488
	489	sub STORE {
	490	$_[0]->{$_[1]} = $_[2];
	491	}
	492
	493	sub FETCH {
	494	$_[0]->{$_[1]}
	495	}
	496
	497	sub CLEAR {
	498	%{ $_[0] } = ();
	499	}
	500
	501	sub SCALAR {
	502	print "SCALAR\n";
	503	return 0 if ! keys %{$_[0]};
	504	sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
	505	}
	506
	507	package main;
	508	tie my %h => "TieScalar";
	509	$h{key1} = "val1";
	510	$h{key2} = "val2";
	511	print scalar %h, "\n";
	512	%h = ();
	513	print scalar %h, "\n";
	514	EXPECT
	515	SCALAR
	516	2/2
	517	SCALAR
	518	0
	519	########
	520
	521	# test scalar on tied hash when no SCALAR method has been given
	522	package TieScalar;
	523
	524	sub TIEHASH {
	525	my $pkg = shift;
	526	bless { } => $pkg;
	527	}
	528	sub STORE {
	529	$_[0]->{$_[1]} = $_[2];
	530	}
	531	sub FETCH {
	532	$_[0]->{$_[1]}
	533	}
	534	sub CLEAR {
	535	%{ $_[0] } = ();
	536	}
	537	sub FIRSTKEY {
	538	my $a = keys %{ $_[0] };
	539	print "FIRSTKEY\n";
	540	each %{ $_[0] };
	541	}
	542
543	package main;
544	tie my %h => "TieScalar";
545
546	if (!%h) {
547	print "empty\n";
548	} else {
549	print "not empty\n";
550	}
551
552	$h{key1} = "val1";
553	print "not empty\n" if %h;
554	print "not empty\n" if %h;
555	print "-->\n";
556	my ($k,$v) = each %h;
557	print "<--\n";
558	print "not empty\n" if %h;
559	%h = ();
560	print "empty\n" if ! %h;
561	EXPECT
562	FIRSTKEY
563	empty
564	FIRSTKEY
565	not empty
566	FIRSTKEY
567	not empty
568	-->
569	FIRSTKEY
570	<--
571	not empty
572	FIRSTKEY
573	empty
2b77b520	574	########
	575	sub TIESCALAR { bless {} }
	576	sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
	577	tie $h, "main";
	578	print $h,"\n";
	579	EXPECT
	580	3.3
c75ab21a	581	########
	582	sub TIESCALAR { bless {} }
	583	sub FETCH { shift()->{i} ++ }
	584	tie $h, "main";
	585	print $h.$h;
	586	EXPECT
	587	01
64207fde	588	########
	589	sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
	590	sub FETCH { ${$_[0]} }
	591	tie my $x, "main", 2;
	592	tie my $y, "main", 8;
	593	print $x \| $y;
	594	EXPECT
	595	10
1baaf5d7	596	########
	597	# Bug 36267
	598	sub TIEHASH { bless {}, $_[0] }
	599	sub STORE { $_[0]->{$_[1]} = $_[2] }
	600	sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
	601	sub NEXTKEY { each %{$_[0]} }
	602	sub DELETE { delete $_[0]->{$_[1]} }
	603	sub CLEAR { %{$_[0]} = () }
	604	$h{b}=1;
	605	delete $h{b};
	606	print scalar keys %h, "\n";
	607	tie %h, 'main';
	608	$i{a}=1;
	609	%h = %i;
	610	untie %h;
	611	print scalar keys %h, "\n";
	612	EXPECT
	613	0
	614	0
ced497e2	615	########
	616	# Bug 37731
	617	sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
	618	sub foo::FETCH { $_[0]->{value} }
	619	tie my $VAR, 'foo', '42';
	620	foreach my $var ($VAR) {
	621	print +($var eq $VAR) ? "yes\n" : "no\n";
	622	}
	623	EXPECT
	624	yes