X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b881518d78374cbb36c0ad56c39aaca9fc97154d..64207fdecf440d47a0141fa8dc2b88f627811e7c:/t/op/tie.t diff --git a/t/op/tie.t b/t/op/tie.t index f8f2322..68a773d 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -1,9 +1,13 @@ #!./perl -# This test harness will (eventually) test the "tie" functionality -# without the need for a *DBM* implementation. - -# Currently it only tests the untie warning +# 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'; @@ -11,29 +15,23 @@ $ENV{PERL5LIB} = "../lib"; $|=1; -# catch warnings into fatal errors -$SIG{__WARN__} = sub { die "WARNING: @_" } ; -$SIG{__DIE__} = sub { die @_ }; - undef $/; -@prgs = split "\n########\n", ; -print "1..", scalar @prgs, "\n"; +@prgs = split /^########\n/m, ; +require './test.pl'; +plan(tests => scalar @prgs); for (@prgs){ - my($prog,$expected) = split(/\nEXPECT\n/, $_); - eval "$prog" ; - $status = $?; - $results = $@ ; + ++$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+$//; - if ( $status or $results and $results !~ /^(WARNING: )?$expected/){ - print STDERR "STATUS: $status\n"; - print STDERR "PROG: $prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; + + fresh_perl_is($prog, $expected, {}, $testname); } __END__ @@ -106,7 +104,7 @@ use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; EXPECT -untie attempted while 1 inner references still exist +untie attempted while 1 inner references still exist at - line 6. ######## # strict behaviour, with 1 extra references via tied generating an error @@ -116,7 +114,7 @@ tie %h, Tie::StdHash; $a = tied %h; untie %h; EXPECT -untie attempted while 1 inner references still exist +untie attempted while 1 inner references still exist at - line 7. ######## # strict behaviour, with 1 extra references which are destroyed @@ -138,14 +136,14 @@ untie %h; EXPECT ######## -# strict error behaviour, with 2 extra references +# 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 +untie attempted while 2 inner references still exist at - line 7. ######## # strict behaviour, check scope of strictness. @@ -162,29 +160,78 @@ $C = $B = tied %H ; untie %H; EXPECT ######## + # Forbidden aggregate self-ties -my ($a, $b) = (0, 0); sub Self::TIEHASH { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 1; } { - my %c = 42; + my %c; tie %c, 'Self', \%c; } EXPECT -Self-ties of arrays and hashes are not supported +Self-ties of arrays and hashes are not supported at - line 6. ######## + # Allowed scalar self-ties -my ($a, $b) = (0, 0); +my $destroyed = 0; sub Self::TIESCALAR { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 1; } +sub Self::DESTROY { $destroyed = 1; } { my $c = 42; - $a = $c + 0; tie $c, 'Self', \$c; } -die unless $a == 0 && $b == 43; +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); @@ -197,17 +244,352 @@ vec($b,1,1)=0; die unless $a eq $b; EXPECT ######## -# An attempt at lvalueable barewords broke this +# 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 ######## -# correct unlocalisation of tied hashes (patch #16431) -use Tie::Hash ; -tie %tied, Tie::StdHash; -{ local $hash{'foo'} } print "exist1\n" if exists $hash{'foo'}; -{ local $tied{'foo'} } print "exist2\n" if exists $tied{'foo'}; -{ local $ENV{'foo'} } print "exist3\n" if exists $ENV{'foo'}; +# +# 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