This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Nit in Configure (bleadperl@6961)
[perl5.git] / t / op / tie.t
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
8 chdir 't' if -d 't';
9 @INC = '../lib';
10 $ENV{PERL5LIB} = "../lib";
11
12 $|=1;
13
14 # catch warnings into fatal errors
15 $SIG{__WARN__} = sub { die "WARNING: @_" } ;
16
17 undef $/;
18 @prgs = split "\n########\n", <DATA>;
19 print "1..", scalar @prgs, "\n";
20
21 for (@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
41 use Tie::Hash ;
42 tie %h, Tie::StdHash;
43 untie %h;
44 EXPECT
45 ########
46
47 # standard behaviour, without any extra references
48 use Tie::Hash ;
49 {package Tie::HashUntie;
50  use base 'Tie::StdHash';
51  sub UNTIE
52   {
53    warn "Untied\n";
54   }
55 }
56 tie %h, Tie::HashUntie;
57 untie %h;
58 EXPECT
59 Untied
60 ########
61
62 # standard behaviour, with 1 extra reference
63 use Tie::Hash ;
64 $a = tie %h, Tie::StdHash;
65 untie %h;
66 EXPECT
67 ########
68
69 # standard behaviour, with 1 extra reference via tied
70 use Tie::Hash ;
71 tie %h, Tie::StdHash;
72 $a = tied %h;
73 untie %h;
74 EXPECT
75 ########
76
77 # standard behaviour, with 1 extra reference which is destroyed
78 use Tie::Hash ;
79 $a = tie %h, Tie::StdHash;
80 $a = 0 ;
81 untie %h;
82 EXPECT
83 ########
84
85 # standard behaviour, with 1 extra reference via tied which is destroyed
86 use Tie::Hash ;
87 tie %h, Tie::StdHash;
88 $a = tied %h;
89 $a = 0 ;
90 untie %h;
91 EXPECT
92 ########
93
94 # strict behaviour, without any extra references
95 use warnings 'untie';
96 use Tie::Hash ;
97 tie %h, Tie::StdHash;
98 untie %h;
99 EXPECT
100 ########
101
102 # strict behaviour, with 1 extra references generating an error
103 use warnings 'untie';
104 use Tie::Hash ;
105 $a = tie %h, Tie::StdHash;
106 untie %h;
107 EXPECT
108 untie attempted while 1 inner references still exist
109 ########
110
111 # strict behaviour, with 1 extra references via tied generating an error
112 use warnings 'untie';
113 use Tie::Hash ;
114 tie %h, Tie::StdHash;
115 $a = tied %h;
116 untie %h;
117 EXPECT
118 untie attempted while 1 inner references still exist
119 ########
120
121 # strict behaviour, with 1 extra references which are destroyed
122 use warnings 'untie';
123 use Tie::Hash ;
124 $a = tie %h, Tie::StdHash;
125 $a = 0 ;
126 untie %h;
127 EXPECT
128 ########
129
130 # strict behaviour, with extra 1 references via tied which are destroyed
131 use warnings 'untie';
132 use Tie::Hash ;
133 tie %h, Tie::StdHash;
134 $a = tied %h;
135 $a = 0 ;
136 untie %h;
137 EXPECT
138 ########
139
140 # strict error behaviour, with 2 extra references 
141 use warnings 'untie';
142 use Tie::Hash ;
143 $a = tie %h, Tie::StdHash;
144 $b = tied %h ;
145 untie %h;
146 EXPECT
147 untie attempted while 2 inner references still exist
148 ########
149
150 # strict behaviour, check scope of strictness.
151 no warnings 'untie';
152 use Tie::Hash ;
153 $A = tie %H, Tie::StdHash;
154 $C = $B = tied %H ;
155 {
156     use warnings 'untie';
157     use Tie::Hash ;
158     tie %h, Tie::StdHash;
159     untie %h;
160 }
161 untie %H;
162 EXPECT
163 ########
164
165 # verify no leak when underlying object is selfsame tied variable
166 my ($a, $b);
167 sub Self::TIEHASH { bless $_[1], $_[0] }
168 sub Self::DESTROY { $b = $_[0] + 0; }
169 {
170     my %b5;
171     $a = \%b5 + 0;
172     tie %b5, 'Self', \%b5;
173 }
174 die unless $a == $b;
175 EXPECT
176 ########
177 # Interaction of tie and vec
178
179 my ($a, $b);
180 use Tie::Scalar;
181 tie $a,Tie::StdScalar or die;
182 vec($b,1,1)=1;
183 $a = $b;
184 vec($a,1,1)=0;
185 vec($b,1,1)=0;
186 die unless $a eq $b;
187 EXPECT