1#!./perl 2 3# This test harness will (eventually) test the "tie" functionality 4# without the need for a *DBM* implementation. 5 6# Currently it only tests the untie warning 7 8chdir 't' if -d 't'; 9unshift @INC, "../lib"; 10$ENV{PERL5LIB} = "../lib"; 11 12$|=1; 13 14# catch warnings into fatal errors 15$SIG{__WARN__} = sub { die "WARNING: @_" } ; 16 17undef $/; 18@prgs = split "\n########\n", <DATA>; 19print "1..", scalar @prgs, "\n"; 20 21for (@prgs){ 22 my($prog,$expected) = split(/\nEXPECT\n/, $_); 23 eval "$prog" ; 24 $status = $?; 25 $results = $@ ; 26 $results =~ s/\n+$//; 27 $expected =~ s/\n+$//; 28 if ( $status or $results and $results !~ /^WARNING: $expected/){ 29 print STDERR "STATUS: $status\n"; 30 print STDERR "PROG: $prog\n"; 31 print STDERR "EXPECTED:\n$expected\n"; 32 print STDERR "GOT:\n$results\n"; 33 print "not "; 34 } 35 print "ok ", ++$i, "\n"; 36} 37 38__END__ 39 40# standard behaviour, without any extra references 41use Tie::Hash ; 42tie %h, Tie::StdHash; 43untie %h; 44EXPECT 45######## 46 47# standard behaviour, with 1 extra reference 48use Tie::Hash ; 49$a = tie %h, Tie::StdHash; 50untie %h; 51EXPECT 52######## 53 54# standard behaviour, with 1 extra reference via tied 55use Tie::Hash ; 56tie %h, Tie::StdHash; 57$a = tied %h; 58untie %h; 59EXPECT 60######## 61 62# standard behaviour, with 1 extra reference which is destroyed 63use Tie::Hash ; 64$a = tie %h, Tie::StdHash; 65$a = 0 ; 66untie %h; 67EXPECT 68######## 69 70# standard behaviour, with 1 extra reference via tied which is destroyed 71use Tie::Hash ; 72tie %h, Tie::StdHash; 73$a = tied %h; 74$a = 0 ; 75untie %h; 76EXPECT 77######## 78 79# strict behaviour, without any extra references 80use warnings 'untie'; 81use Tie::Hash ; 82tie %h, Tie::StdHash; 83untie %h; 84EXPECT 85######## 86 87# strict behaviour, with 1 extra references generating an error 88use warnings 'untie'; 89use Tie::Hash ; 90$a = tie %h, Tie::StdHash; 91untie %h; 92EXPECT 93untie attempted while 1 inner references still exist 94######## 95 96# strict behaviour, with 1 extra references via tied generating an error 97use warnings 'untie'; 98use Tie::Hash ; 99tie %h, Tie::StdHash; 100$a = tied %h; 101untie %h; 102EXPECT 103untie attempted while 1 inner references still exist 104######## 105 106# strict behaviour, with 1 extra references which are destroyed 107use warnings 'untie'; 108use Tie::Hash ; 109$a = tie %h, Tie::StdHash; 110$a = 0 ; 111untie %h; 112EXPECT 113######## 114 115# strict behaviour, with extra 1 references via tied which are destroyed 116use warnings 'untie'; 117use Tie::Hash ; 118tie %h, Tie::StdHash; 119$a = tied %h; 120$a = 0 ; 121untie %h; 122EXPECT 123######## 124 125# strict error behaviour, with 2 extra references 126use warnings 'untie'; 127use Tie::Hash ; 128$a = tie %h, Tie::StdHash; 129$b = tied %h ; 130untie %h; 131EXPECT 132untie attempted while 2 inner references still exist 133######## 134 135# strict behaviour, check scope of strictness. 136no warnings 'untie'; 137use Tie::Hash ; 138$A = tie %H, Tie::StdHash; 139$C = $B = tied %H ; 140{ 141 use warnings 'untie'; 142 use Tie::Hash ; 143 tie %h, Tie::StdHash; 144 untie %h; 145} 146untie %H; 147EXPECT 148######## 149 150# verify no leak when underlying object is selfsame tied variable 151my ($a, $b); 152sub Self::TIEHASH { bless $_[1], $_[0] } 153sub Self::DESTROY { $b = $_[0] + 0; } 154{ 155 my %b5; 156 $a = \%b5 + 0; 157 tie %b5, 'Self', \%b5; 158} 159die unless $a == $b; 160EXPECT 161######## 162# Interaction of tie and vec 163 164my ($a, $b); 165use Tie::Scalar; 166tie $a,Tie::StdScalar or die; 167vec($b,1,1)=1; 168$a = $b; 169vec($a,1,1)=0; 170vec($b,1,1)=0; 171die unless $a eq $b; 172EXPECT 173