[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";
my $s = $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
########

# [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>";
    return $$self;
}
package main;

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

# 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"
    if %h; # this should also call SCALAR but implicitly
%h = ();
print scalar %h, "\n"
    if !%h; # this should also call SCALAR but implicitly
EXPECT
SCALAR
SCALAR
2/2
SCALAR
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
########
# Bug 53482 (and maybe others)
sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
sub FETCH { ${$_[0]} }
tie my $x1, "main", 2;
tie my $y1, "main", 8;
print $x1 | $y1;
print $x1 | $y1;
tie my $x2, "main", "2";
tie my $y2, "main", "8";
print $x2 | $y2;
print $x2 | $y2;
EXPECT
1010::
########
# 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
########
sub TIEARRAY { bless [], 'main' }
{
    local @a;
    tie @a, 'main';
}
print "tied\n" if tied @a;
EXPECT
########
sub TIEHASH { bless [], 'main' }
{
    local %h;
    tie %h, 'main';
}
print "tied\n" if tied %h;
EXPECT
########
# RT 20727: PL_defoutgv is left as a tied element
sub TIESCALAR { return bless {}, 'main' }

sub STORE {
    select($_[1]);
    $_[1] = 1;
    select(); # this used to coredump or assert fail
}
tie $SELECT, 'main';
$SELECT = *STDERR;
EXPECT
########
# RT 23810: eval in die in FETCH can corrupt context stack

my $file = 'rt23810.pm';

my $e;
my $s;

sub do_require {
    my ($str, $eval) = @_;
    open my $fh, '>', $file or die "Can't create $file: $!\n";
    print $fh $str;
    close $fh;
    if ($eval) {
	$s .= '-ERQ';
	eval { require $pm; $s .= '-ENDE' }
    }
    else {
	$s .= '-RQ';
	require $pm;
    }
    $s .= '-ENDRQ';
    unlink $file;
}

sub TIEHASH { bless {} }

sub FETCH {
    # 10 or more syntax errors makes yyparse croak()
    my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};

    if ($_[1] eq 'eval') {
	$s .= 'EVAL';
	eval q[BEGIN { die; $s .= '-X1' }];
	$s .= '-BD';
	eval q[BEGIN { $x+ }];
	$s .= '-BS';
	eval '$x+';
	$s .= '-E1';
	$s .= '-S1' while $@ =~ /syntax error at/g;
	eval $bad;
	$s .= '-E2';
	$s .= '-S2' while $@ =~ /syntax error at/g;
    }
    elsif ($_[1] eq 'require') {
	$s .= 'REQUIRE';
	my @text = (
	    q[BEGIN { die; $s .= '-X1' }],
	    q[BEGIN { $x+ }],
	    '$x+',
	    $bad
	);
	for my $i (0..$#text) {
	    $s .= "-$i";
	    do_require($txt[$i], 0) if $e;;
	    do_require($txt[$i], 1);
	}
    }
    elsif ($_[1] eq 'exit') {
	eval q[exit(0); print "overshot eval\n"];
    }
    else {
	print "unknown key: '$_[1]'\n";
    }
    return "-R";
}
my %foo;
tie %foo, "main";

for my $action(qw(eval require)) {
    $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
    $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
    $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
    $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
}
1 while unlink $file;

$foo{'exit'};
print "overshot main\n"; # shouldn't reach here

EXPECT
eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
require: s1=REQUIRE-0-RQ
require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
require: s3=REQUIRE-0-RQ
########
# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
#          element

sub TIEARRAY { bless [], $_[0] }
sub TIEHASH  { bless [], $_[0] }
sub FETCH { $_[0]->[$_[1]] }
sub STORE { $_[0]->[$_[1]] = $_[2] }


sub f {
    local $_[0];
}
tie @a, 'main';
tie %h, 'main';

foreach ($a[0], $h{a}) {
    f($_);
}
# on failure, chucks up 'premature free' etc messages
EXPECT
########
# RT 5475:
# the initial fix for this bug caused tied scalar FETCH to be called
# multiple times when that scalar was an element in an array. Check it
# only gets called once now.

sub TIESCALAR { bless [], $_[0] }
my $c = 0;
sub FETCH { $c++; 0 }
sub FETCHSIZE { 1 }
sub STORE { $c += 100; 0 }


my (@a, %h);
tie $a[0],   'main';
tie $h{foo}, 'main';

my $i = 0;
my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
print "x=$x c=$c\n";
EXPECT
x=0 c=4
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";
39cf747a	340	my $s = $a->{foo}; # access once
38193a09	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	########
6c0731c3	449
e23d9e2f	450	# [perl #948] cannot meaningfully tie $,
6c0731c3	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;
e23d9e2f	466	print "<FETCH>";
6c0731c3	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'
e23d9e2f	476	join<FETCH>BOBBINSthings<FETCH>BOBBINSup
a3bcc51e	477	########
	478
	479	# test SCALAR method
	480	package TieScalar;
	481
	482	sub TIEHASH {
	483	my $pkg = shift;
	484	bless { } => $pkg;
	485	}
	486
	487	sub STORE {
	488	$_[0]->{$_[1]} = $_[2];
	489	}
	490
	491	sub FETCH {
	492	$_[0]->{$_[1]}
	493	}
	494
	495	sub CLEAR {
	496	%{ $_[0] } = ();
	497	}
	498
	499	sub SCALAR {
	500	print "SCALAR\n";
	501	return 0 if ! keys %{$_[0]};
	502	sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
	503	}
	504
	505	package main;
	506	tie my %h => "TieScalar";
	507	$h{key1} = "val1";
	508	$h{key2} = "val2";
867fa1e2	509	print scalar %h, "\n"
867fa1e2	510	if %h; # this should also call SCALAR but implicitly
a3bcc51e	511	%h = ();
867fa1e2	512	print scalar %h, "\n"
867fa1e2	513	if !%h; # this should also call SCALAR but implicitly
a3bcc51e	514	EXPECT
a3bcc51e	515	SCALAR
867fa1e2	516	SCALAR
a3bcc51e	517	2/2
a3bcc51e	518	SCALAR
867fa1e2	519	SCALAR
a3bcc51e	520	0
	521	########
	522
	523	# test scalar on tied hash when no SCALAR method has been given
	524	package TieScalar;
	525
	526	sub TIEHASH {
	527	my $pkg = shift;
	528	bless { } => $pkg;
	529	}
	530	sub STORE {
	531	$_[0]->{$_[1]} = $_[2];
	532	}
	533	sub FETCH {
	534	$_[0]->{$_[1]}
	535	}
	536	sub CLEAR {
	537	%{ $_[0] } = ();
	538	}
	539	sub FIRSTKEY {
	540	my $a = keys %{ $_[0] };
	541	print "FIRSTKEY\n";
	542	each %{ $_[0] };
	543	}
	544
	545	package main;
	546	tie my %h => "TieScalar";
	547
	548	if (!%h) {
	549	print "empty\n";
	550	} else {
	551	print "not empty\n";
	552	}
	553
	554	$h{key1} = "val1";
	555	print "not empty\n" if %h;
	556	print "not empty\n" if %h;
	557	print "-->\n";
	558	my ($k,$v) = each %h;
	559	print "<--\n";
	560	print "not empty\n" if %h;
	561	%h = ();
	562	print "empty\n" if ! %h;
	563	EXPECT
	564	FIRSTKEY
	565	empty
	566	FIRSTKEY
	567	not empty
	568	FIRSTKEY
	569	not empty
	570	-->
	571	FIRSTKEY
	572	<--
	573	not empty
	574	FIRSTKEY
	575	empty
2b77b520	576	########
	577	sub TIESCALAR { bless {} }
	578	sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
	579	tie $h, "main";
	580	print $h,"\n";
	581	EXPECT
	582	3.3
c75ab21a	583	########
	584	sub TIESCALAR { bless {} }
	585	sub FETCH { shift()->{i} ++ }
	586	tie $h, "main";
	587	print $h.$h;
	588	EXPECT
	589	01
64207fde	590	########
7de9d14e	591	# Bug 53482 (and maybe others)
64207fde	592	sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
64207fde	593	sub FETCH { ${$_[0]} }
7de9d14e	594	tie my $x1, "main", 2;
	595	tie my $y1, "main", 8;
	596	print $x1 \| $y1;
	597	print $x1 \| $y1;
	598	tie my $x2, "main", "2";
	599	tie my $y2, "main", "8";
	600	print $x2 \| $y2;
	601	print $x2 \| $y2;
	602	EXPECT
	603	1010::
1baaf5d7	604	########
	605	# Bug 36267
	606	sub TIEHASH { bless {}, $_[0] }
	607	sub STORE { $_[0]->{$_[1]} = $_[2] }
	608	sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
	609	sub NEXTKEY { each %{$_[0]} }
	610	sub DELETE { delete $_[0]->{$_[1]} }
	611	sub CLEAR { %{$_[0]} = () }
	612	$h{b}=1;
	613	delete $h{b};
	614	print scalar keys %h, "\n";
	615	tie %h, 'main';
	616	$i{a}=1;
	617	%h = %i;
	618	untie %h;
	619	print scalar keys %h, "\n";
	620	EXPECT
	621	0
	622	0
ced497e2	623	########
	624	# Bug 37731
	625	sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
	626	sub foo::FETCH { $_[0]->{value} }
	627	tie my $VAR, 'foo', '42';
	628	foreach my $var ($VAR) {
	629	print +($var eq $VAR) ? "yes\n" : "no\n";
	630	}
	631	EXPECT
	632	yes
f4c21a45	633	########
	634	sub TIEARRAY { bless [], 'main' }
	635	{
	636	local @a;
	637	tie @a, 'main';
	638	}
	639	print "tied\n" if tied @a;
	640	EXPECT
	641	########
	642	sub TIEHASH { bless [], 'main' }
	643	{
	644	local %h;
	645	tie %h, 'main';
	646	}
	647	print "tied\n" if tied %h;
	648	EXPECT
099be4f1	649	########
	650	# RT 20727: PL_defoutgv is left as a tied element
	651	sub TIESCALAR { return bless {}, 'main' }
	652
	653	sub STORE {
	654	select($_[1]);
	655	$_[1] = 1;
	656	select(); # this used to coredump or assert fail
	657	}
	658	tie $SELECT, 'main';
	659	$SELECT = *STDERR;
	660	EXPECT
27e90453	661	########
	662	# RT 23810: eval in die in FETCH can corrupt context stack
	663
	664	my $file = 'rt23810.pm';
	665
	666	my $e;
	667	my $s;
	668
	669	sub do_require {
	670	my ($str, $eval) = @_;
	671	open my $fh, '>', $file or die "Can't create $file: $!\n";
	672	print $fh $str;
	673	close $fh;
	674	if ($eval) {
	675	$s .= '-ERQ';
	676	eval { require $pm; $s .= '-ENDE' }
	677	}
	678	else {
	679	$s .= '-RQ';
	680	require $pm;
	681	}
	682	$s .= '-ENDRQ';
	683	unlink $file;
	684	}
	685
	686	sub TIEHASH { bless {} }
	687
	688	sub FETCH {
	689	# 10 or more syntax errors makes yyparse croak()
	690	my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
	691
	692	if ($_[1] eq 'eval') {
	693	$s .= 'EVAL';
	694	eval q[BEGIN { die; $s .= '-X1' }];
	695	$s .= '-BD';
	696	eval q[BEGIN { $x+ }];
	697	$s .= '-BS';
	698	eval '$x+';
	699	$s .= '-E1';
	700	$s .= '-S1' while $@ =~ /syntax error at/g;
	701	eval $bad;
	702	$s .= '-E2';
	703	$s .= '-S2' while $@ =~ /syntax error at/g;
	704	}
	705	elsif ($_[1] eq 'require') {
	706	$s .= 'REQUIRE';
	707	my @text = (
	708	q[BEGIN { die; $s .= '-X1' }],
	709	q[BEGIN { $x+ }],
	710	'$x+',
	711	$bad
	712	);
	713	for my $i (0..$#text) {
	714	$s .= "-$i";
	715	do_require($txt[$i], 0) if $e;;
	716	do_require($txt[$i], 1);
	717	}
	718	}
	719	elsif ($_[1] eq 'exit') {
	720	eval q[exit(0); print "overshot eval\n"];
	721	}
	722	else {
	723	print "unknown key: '$_[1]'\n";
	724	}
725	return "-R";
726	}
727	my %foo;
728	tie %foo, "main";
729
730	for my $action(qw(eval require)) {
731	$s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
732	$s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
733	$s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
734	$s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
735	}
736	1 while unlink $file;
737
738	$foo{'exit'};
739	print "overshot main\n"; # shouldn't reach here
740
741	EXPECT
742	eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
743	eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
744	eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
745	eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
746	require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
747	require: s1=REQUIRE-0-RQ
748	require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
749	require: s3=REQUIRE-0-RQ
459defa1	750	########
	751	# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
	752	# element
	753
	754	sub TIEARRAY { bless [], $_[0] }
	755	sub TIEHASH { bless [], $_[0] }
	756	sub FETCH { $_[0]->[$_[1]] }
	757	sub STORE { $_[0]->[$_[1]] = $_[2] }
	758
	759
	760	sub f {
	761	local $_[0];
	762	}
	763	tie @a, 'main';
	764	tie %h, 'main';
27e90453	765
459defa1	766	foreach ($a[0], $h{a}) {
	767	f($_);
	768	}
	769	# on failure, chucks up 'premature free' etc messages
	770	EXPECT
39cf747a	771	########
	772	# RT 5475:
	773	# the initial fix for this bug caused tied scalar FETCH to be called
	774	# multiple times when that scalar was an element in an array. Check it
	775	# only gets called once now.
	776
	777	sub TIESCALAR { bless [], $_[0] }
	778	my $c = 0;
	779	sub FETCH { $c++; 0 }
	780	sub FETCHSIZE { 1 }
	781	sub STORE { $c += 100; 0 }
	782
	783
	784	my (@a, %h);
	785	tie $a[0], 'main';
	786	tie $h{foo}, 'main';
	787
	788	my $i = 0;
	789	my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
	790	print "x=$x c=$c\n";
	791	EXPECT
	792	x=0 c=4