1N/A#!./perl
1N/A
1N/A# Add new tests to the end with format:
1N/A# ########
1N/A#
1N/A# # test description
1N/A# Test code
1N/A# EXPECT
1N/A# Warn or die msgs (if any) at - line 1234
1N/A#
1N/A
1N/Achdir 't' if -d 't';
1N/A@INC = '../lib';
1N/A$ENV{PERL5LIB} = "../lib";
1N/A
1N/A$|=1;
1N/A
1N/Aundef $/;
1N/A@prgs = split /^########\n/m, <DATA>;
1N/A
1N/Arequire './test.pl';
1N/Aplan(tests => scalar @prgs);
1N/Afor (@prgs){
1N/A ++$i;
1N/A my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
1N/A print("not ok $i # bad test format\n"), next
1N/A unless defined $expected;
1N/A my ($testname) = $prog =~ /^# (.*)\n/m;
1N/A $testname ||= '';
1N/A $TODO = $testname =~ s/^TODO //;
1N/A $results =~ s/\n+$//;
1N/A $expected =~ s/\n+$//;
1N/A
1N/A fresh_perl_is($prog, $expected, {}, $testname);
1N/A}
1N/A
1N/A__END__
1N/A
1N/A# standard behaviour, without any extra references
1N/Ause Tie::Hash ;
1N/Atie %h, Tie::StdHash;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# standard behaviour, without any extra references
1N/Ause Tie::Hash ;
1N/A{package Tie::HashUntie;
1N/A use base 'Tie::StdHash';
1N/A sub UNTIE
1N/A {
1N/A warn "Untied\n";
1N/A }
1N/A}
1N/Atie %h, Tie::HashUntie;
1N/Auntie %h;
1N/AEXPECT
1N/AUntied
1N/A########
1N/A
1N/A# standard behaviour, with 1 extra reference
1N/Ause Tie::Hash ;
1N/A$a = tie %h, Tie::StdHash;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# standard behaviour, with 1 extra reference via tied
1N/Ause Tie::Hash ;
1N/Atie %h, Tie::StdHash;
1N/A$a = tied %h;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# standard behaviour, with 1 extra reference which is destroyed
1N/Ause Tie::Hash ;
1N/A$a = tie %h, Tie::StdHash;
1N/A$a = 0 ;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# standard behaviour, with 1 extra reference via tied which is destroyed
1N/Ause Tie::Hash ;
1N/Atie %h, Tie::StdHash;
1N/A$a = tied %h;
1N/A$a = 0 ;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# strict behaviour, without any extra references
1N/Ause warnings 'untie';
1N/Ause Tie::Hash ;
1N/Atie %h, Tie::StdHash;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# strict behaviour, with 1 extra references generating an error
1N/Ause warnings 'untie';
1N/Ause Tie::Hash ;
1N/A$a = tie %h, Tie::StdHash;
1N/Auntie %h;
1N/AEXPECT
1N/Auntie attempted while 1 inner references still exist at - line 6.
1N/A########
1N/A
1N/A# strict behaviour, with 1 extra references via tied generating an error
1N/Ause warnings 'untie';
1N/Ause Tie::Hash ;
1N/Atie %h, Tie::StdHash;
1N/A$a = tied %h;
1N/Auntie %h;
1N/AEXPECT
1N/Auntie attempted while 1 inner references still exist at - line 7.
1N/A########
1N/A
1N/A# strict behaviour, with 1 extra references which are destroyed
1N/Ause warnings 'untie';
1N/Ause Tie::Hash ;
1N/A$a = tie %h, Tie::StdHash;
1N/A$a = 0 ;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# strict behaviour, with extra 1 references via tied which are destroyed
1N/Ause warnings 'untie';
1N/Ause Tie::Hash ;
1N/Atie %h, Tie::StdHash;
1N/A$a = tied %h;
1N/A$a = 0 ;
1N/Auntie %h;
1N/AEXPECT
1N/A########
1N/A
1N/A# strict error behaviour, with 2 extra references
1N/Ause warnings 'untie';
1N/Ause Tie::Hash ;
1N/A$a = tie %h, Tie::StdHash;
1N/A$b = tied %h ;
1N/Auntie %h;
1N/AEXPECT
1N/Auntie attempted while 2 inner references still exist at - line 7.
1N/A########
1N/A
1N/A# strict behaviour, check scope of strictness.
1N/Ano warnings 'untie';
1N/Ause Tie::Hash ;
1N/A$A = tie %H, Tie::StdHash;
1N/A$C = $B = tied %H ;
1N/A{
1N/A use warnings 'untie';
1N/A use Tie::Hash ;
1N/A tie %h, Tie::StdHash;
1N/A untie %h;
1N/A}
1N/Auntie %H;
1N/AEXPECT
1N/A########
1N/A
1N/A# Forbidden aggregate self-ties
1N/Asub Self::TIEHASH { bless $_[1], $_[0] }
1N/A{
1N/A my %c;
1N/A tie %c, 'Self', \%c;
1N/A}
1N/AEXPECT
1N/ASelf-ties of arrays and hashes are not supported at - line 6.
1N/A########
1N/A
1N/A# Allowed scalar self-ties
1N/Amy $destroyed = 0;
1N/Asub Self::TIESCALAR { bless $_[1], $_[0] }
1N/Asub Self::DESTROY { $destroyed = 1; }
1N/A{
1N/A my $c = 42;
1N/A tie $c, 'Self', \$c;
1N/A}
1N/Adie "self-tied scalar not DESTROYed" unless $destroyed == 1;
1N/AEXPECT
1N/A########
1N/A
1N/A# Allowed glob self-ties
1N/Amy $destroyed = 0;
1N/Amy $printed = 0;
1N/Asub Self2::TIEHANDLE { bless $_[1], $_[0] }
1N/Asub Self2::DESTROY { $destroyed = 1; }
1N/Asub Self2::PRINT { $printed = 1; }
1N/A{
1N/A use Symbol;
1N/A my $c = gensym;
1N/A tie *$c, 'Self2', $c;
1N/A print $c 'Hello';
1N/A}
1N/Adie "self-tied glob not PRINTed" unless $printed == 1;
1N/Adie "self-tied glob not DESTROYed" unless $destroyed == 1;
1N/AEXPECT
1N/A########
1N/A
1N/A# Allowed IO self-ties
1N/Amy $destroyed = 0;
1N/Asub Self3::TIEHANDLE { bless $_[1], $_[0] }
1N/Asub Self3::DESTROY { $destroyed = 1; }
1N/Asub Self3::PRINT { $printed = 1; }
1N/A{
1N/A use Symbol 'geniosym';
1N/A my $c = geniosym;
1N/A tie *$c, 'Self3', $c;
1N/A print $c 'Hello';
1N/A}
1N/Adie "self-tied IO not PRINTed" unless $printed == 1;
1N/Adie "self-tied IO not DESTROYed" unless $destroyed == 1;
1N/AEXPECT
1N/A########
1N/A
1N/A# TODO IO "self-tie" via TEMP glob
1N/Amy $destroyed = 0;
1N/Asub Self3::TIEHANDLE { bless $_[1], $_[0] }
1N/Asub Self3::DESTROY { $destroyed = 1; }
1N/Asub Self3::PRINT { $printed = 1; }
1N/A{
1N/A use Symbol 'geniosym';
1N/A my $c = geniosym;
1N/A tie *$c, 'Self3', \*$c;
1N/A print $c 'Hello';
1N/A}
1N/Adie "IO tied to TEMP glob not PRINTed" unless $printed == 1;
1N/Adie "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
1N/AEXPECT
1N/A########
1N/A
1N/A# Interaction of tie and vec
1N/A
1N/Amy ($a, $b);
1N/Ause Tie::Scalar;
1N/Atie $a,Tie::StdScalar or die;
1N/Avec($b,1,1)=1;
1N/A$a = $b;
1N/Avec($a,1,1)=0;
1N/Avec($b,1,1)=0;
1N/Adie unless $a eq $b;
1N/AEXPECT
1N/A########
1N/A
1N/A# correct unlocalisation of tied hashes (patch #16431)
1N/Ause Tie::Hash ;
1N/Atie %tied, Tie::StdHash;
1N/A{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
1N/A{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
1N/A{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
1N/AEXPECT
1N/A########
1N/A
1N/A# An attempt at lvalueable barewords broke this
1N/Atie FH, 'main';
1N/AEXPECT
1N/ACan't modify constant item in tie at - line 3, near "'main';"
1N/AExecution of - aborted due to compilation errors.
1N/A########
1N/A
1N/A# localizing tied hash slices
1N/A$ENV{FooA} = 1;
1N/A$ENV{FooB} = 2;
1N/Aprint exists $ENV{FooA} ? 1 : 0, "\n";
1N/Aprint exists $ENV{FooB} ? 2 : 0, "\n";
1N/Aprint exists $ENV{FooC} ? 3 : 0, "\n";
1N/A{
1N/A local @ENV{qw(FooA FooC)};
1N/A print exists $ENV{FooA} ? 4 : 0, "\n";
1N/A print exists $ENV{FooB} ? 5 : 0, "\n";
1N/A print exists $ENV{FooC} ? 6 : 0, "\n";
1N/A}
1N/Aprint exists $ENV{FooA} ? 7 : 0, "\n";
1N/Aprint exists $ENV{FooB} ? 8 : 0, "\n";
1N/Aprint exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
1N/AEXPECT
1N/A1
1N/A2
1N/A0
1N/A4
1N/A5
1N/A6
1N/A7
1N/A8
1N/A0
1N/A########
1N/A#
1N/A# FETCH freeing tie'd SV
1N/Asub TIESCALAR { bless [] }
1N/Asub FETCH { *a = \1; 1 }
1N/Atie $a, 'main';
1N/Aprint $a;
1N/AEXPECT
1N/ATied variable freed while still in use at - line 6.
1N/A########
1N/A
1N/A# [20020716.007] - nested FETCHES
1N/A
1N/Asub F1::TIEARRAY { bless [], 'F1' }
1N/Asub F1::FETCH { 1 }
1N/Amy @f1;
1N/Atie @f1, 'F1';
1N/A
1N/Asub F2::TIEARRAY { bless [2], 'F2' }
1N/Asub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
1N/Amy @f2;
1N/Atie @f2, 'F2';
1N/A
1N/Aprint $f2[4][0],"\n";
1N/A
1N/Asub F3::TIEHASH { bless [], 'F3' }
1N/Asub F3::FETCH { 1 }
1N/Amy %f3;
1N/Atie %f3, 'F3';
1N/A
1N/Asub F4::TIEHASH { bless [3], 'F4' }
1N/Asub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
1N/Amy %f4;
1N/Atie %f4, 'F4';
1N/A
1N/Aprint $f4{'foo'}[0],"\n";
1N/A
1N/AEXPECT
1N/A2
1N/A3
1N/A########
1N/A# test untie() from within FETCH
1N/Apackage Foo;
1N/Asub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
1N/Asub FETCH {
1N/A my $self = shift;
1N/A my ($obj, $field) = @$self;
1N/A untie $obj->{$field};
1N/A $obj->{$field} = "Bar";
1N/A}
1N/Apackage main;
1N/Atie $a->{foo}, "Foo", $a, "foo";
1N/A$a->{foo}; # access once
1N/A# the hash element should not be tied anymore
1N/Aprint defined tied $a->{foo} ? "not ok" : "ok";
1N/AEXPECT
1N/Aok
1N/A########
1N/A# the tmps returned by FETCH should appear to be SCALAR
1N/A# (even though they are now implemented using PVLVs.)
1N/Apackage X;
1N/Asub TIEHASH { bless {} }
1N/Asub TIEARRAY { bless {} }
1N/Asub FETCH {1}
1N/Amy (%h, @a);
1N/Atie %h, 'X';
1N/Atie @a, 'X';
1N/Amy $r1 = \$h{1};
1N/Amy $r2 = \$a[0];
1N/Amy $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
1N/A$s=~ s/\(0x\w+\)//g;
1N/Aprint $s, "\n";
1N/AEXPECT
1N/ASCALAR SCALAR SCALAR SCALAR
1N/A########
1N/A# [perl #23287] segfault in untie
1N/Asub TIESCALAR { bless $_[1], $_[0] }
1N/Amy $var;
1N/Atie $var, 'main', \$var;
1N/Auntie $var;
1N/AEXPECT
1N/A########
1N/A# Test case from perlmonks by runrig
1N/A# http://www.perlmonks.org/index.pl?node_id=273490
1N/A# "Here is what I tried. I think its similar to what you've tried
1N/A# above. Its odd but convienient that after untie'ing you are left with
1N/A# a variable that has the same value as was last returned from
1N/A# FETCH. (At least on my perl v5.6.1). So you don't need to pass a
1N/A# reference to the variable in order to set it after the untie (here it
1N/A# is accessed through a closure)."
1N/Ause strict;
1N/Ause warnings;
1N/Apackage MyTied;
1N/Asub TIESCALAR {
1N/A my ($class,$code) = @_;
1N/A bless $code, $class;
1N/A}
1N/Asub FETCH {
1N/A my $self = shift;
1N/A print "Untie\n";
1N/A $self->();
1N/A}
1N/Apackage main;
1N/Amy $var;
1N/Atie $var, 'MyTied', sub { untie $var; 4 };
1N/Aprint "One\n";
1N/Aprint "$var\n";
1N/Aprint "Two\n";
1N/Aprint "$var\n";
1N/Aprint "Three\n";
1N/Aprint "$var\n";
1N/AEXPECT
1N/AOne
1N/AUntie
1N/A4
1N/ATwo
1N/A4
1N/AThree
1N/A4
1N/A########
1N/A# [perl #22297] cannot untie scalar from within tied FETCH
1N/Amy $counter = 0;
1N/Amy $x = 7;
1N/Amy $ref = \$x;
1N/Atie $x, 'Overlay', $ref, $x;
1N/Amy $y;
1N/A$y = $x;
1N/A$y = $x;
1N/A$y = $x;
1N/A$y = $x;
1N/A#print "WILL EXTERNAL UNTIE $ref\n";
1N/Auntie $$ref;
1N/A$y = $x;
1N/A$y = $x;
1N/A$y = $x;
1N/A$y = $x;
1N/A#print "counter = $counter\n";
1N/A
1N/Aprint (($counter == 1) ? "ok\n" : "not ok\n");
1N/A
1N/Apackage Overlay;
1N/A
1N/Asub TIESCALAR
1N/A{
1N/A my $pkg = shift;
1N/A my ($ref, $val) = @_;
1N/A return bless [ $ref, $val ], $pkg;
1N/A}
1N/A
1N/Asub FETCH
1N/A{
1N/A my $self = shift;
1N/A my ($ref, $val) = @$self;
1N/A #print "WILL INTERNAL UNITE $ref\n";
1N/A $counter++;
1N/A untie $$ref;
1N/A return $val;
1N/A}
1N/AEXPECT
1N/Aok
1N/A########
1N/A
1N/A# test SCALAR method
1N/Apackage TieScalar;
1N/A
1N/Asub TIEHASH {
1N/A my $pkg = shift;
1N/A bless { } => $pkg;
1N/A}
1N/A
1N/Asub STORE {
1N/A $_[0]->{$_[1]} = $_[2];
1N/A}
1N/A
1N/Asub FETCH {
1N/A $_[0]->{$_[1]}
1N/A}
1N/A
1N/Asub CLEAR {
1N/A %{ $_[0] } = ();
1N/A}
1N/A
1N/Asub SCALAR {
1N/A print "SCALAR\n";
1N/A return 0 if ! keys %{$_[0]};
1N/A sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
1N/A}
1N/A
1N/Apackage main;
1N/Atie my %h => "TieScalar";
1N/A$h{key1} = "val1";
1N/A$h{key2} = "val2";
1N/Aprint scalar %h, "\n";
1N/A%h = ();
1N/Aprint scalar %h, "\n";
1N/AEXPECT
1N/ASCALAR
1N/A2/2
1N/ASCALAR
1N/A0
1N/A########
1N/A
1N/A# test scalar on tied hash when no SCALAR method has been given
1N/Apackage TieScalar;
1N/A
1N/Asub TIEHASH {
1N/A my $pkg = shift;
1N/A bless { } => $pkg;
1N/A}
1N/Asub STORE {
1N/A $_[0]->{$_[1]} = $_[2];
1N/A}
1N/Asub FETCH {
1N/A $_[0]->{$_[1]}
1N/A}
1N/Asub CLEAR {
1N/A %{ $_[0] } = ();
1N/A}
1N/Asub FIRSTKEY {
1N/A my $a = keys %{ $_[0] };
1N/A print "FIRSTKEY\n";
1N/A each %{ $_[0] };
1N/A}
1N/A
1N/Apackage main;
1N/Atie my %h => "TieScalar";
1N/A
1N/Aif (!%h) {
1N/A print "empty\n";
1N/A} else {
1N/A print "not empty\n";
1N/A}
1N/A
1N/A$h{key1} = "val1";
1N/Aprint "not empty\n" if %h;
1N/Aprint "not empty\n" if %h;
1N/Aprint "-->\n";
1N/Amy ($k,$v) = each %h;
1N/Aprint "<--\n";
1N/Aprint "not empty\n" if %h;
1N/A%h = ();
1N/Aprint "empty\n" if ! %h;
1N/AEXPECT
1N/AFIRSTKEY
1N/Aempty
1N/AFIRSTKEY
1N/Anot empty
1N/AFIRSTKEY
1N/Anot empty
1N/A-->
1N/AFIRSTKEY
1N/A<--
1N/Anot empty
1N/AFIRSTKEY
1N/Aempty