Commit | Line | Data |
49d42823 |
1 | #!./perl |
2 | |
3 | # This test harness will (eventually) test the "tie" functionality |
4 | # without the need for a *DBM* implementation. |
5 | |
55497cff |
6 | # Currently it only tests the untie warning |
49d42823 |
7 | |
8 | chdir 't' if -d 't'; |
20822f61 |
9 | @INC = '../lib'; |
49d42823 |
10 | $ENV{PERL5LIB} = "../lib"; |
11 | |
12 | $|=1; |
13 | |
55497cff |
14 | # catch warnings into fatal errors |
15 | $SIG{__WARN__} = sub { die "WARNING: @_" } ; |
16 | |
49d42823 |
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+$//; |
55497cff |
28 | if ( $status or $results and $results !~ /^WARNING: $expected/){ |
49d42823 |
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 | |
a29a5827 |
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 | |
49d42823 |
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 |
4438c4b7 |
95 | use warnings 'untie'; |
49d42823 |
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 |
4438c4b7 |
103 | use warnings 'untie'; |
49d42823 |
104 | use Tie::Hash ; |
105 | $a = tie %h, Tie::StdHash; |
106 | untie %h; |
107 | EXPECT |
55497cff |
108 | untie attempted while 1 inner references still exist |
49d42823 |
109 | ######## |
110 | |
111 | # strict behaviour, with 1 extra references via tied generating an error |
4438c4b7 |
112 | use warnings 'untie'; |
49d42823 |
113 | use Tie::Hash ; |
114 | tie %h, Tie::StdHash; |
115 | $a = tied %h; |
116 | untie %h; |
117 | EXPECT |
55497cff |
118 | untie attempted while 1 inner references still exist |
49d42823 |
119 | ######## |
120 | |
121 | # strict behaviour, with 1 extra references which are destroyed |
4438c4b7 |
122 | use warnings 'untie'; |
49d42823 |
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 |
4438c4b7 |
131 | use warnings 'untie'; |
49d42823 |
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 |
4438c4b7 |
141 | use warnings 'untie'; |
49d42823 |
142 | use Tie::Hash ; |
143 | $a = tie %h, Tie::StdHash; |
144 | $b = tied %h ; |
145 | untie %h; |
146 | EXPECT |
55497cff |
147 | untie attempted while 2 inner references still exist |
49d42823 |
148 | ######## |
149 | |
150 | # strict behaviour, check scope of strictness. |
4438c4b7 |
151 | no warnings 'untie'; |
49d42823 |
152 | use Tie::Hash ; |
153 | $A = tie %H, Tie::StdHash; |
154 | $C = $B = tied %H ; |
155 | { |
4438c4b7 |
156 | use warnings 'untie'; |
49d42823 |
157 | use Tie::Hash ; |
158 | tie %h, Tie::StdHash; |
159 | untie %h; |
160 | } |
161 | untie %H; |
162 | EXPECT |
33c27489 |
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 |
7bb043c3 |
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 |