Commit | Line | Data |
49d42823 |
1 | #!./perl |
2 | |
96e82bbb |
3 | # Add new tests to the end with format: |
4 | # "########\n# test description\nTest code\nEXPECT\nWarn or die msgs (if any)\n" |
5 | # |
6 | # This test script does NOT test the output of the test code. It ONLY |
7 | # checks warnings or croaks. Todo tests should have TODO as the start |
8 | # of the description. Note also that warnings are not enabled: if you |
9 | # need to test a perl warning, enable its class in your test. |
49d42823 |
10 | |
11 | chdir 't' if -d 't'; |
20822f61 |
12 | @INC = '../lib'; |
49d42823 |
13 | $ENV{PERL5LIB} = "../lib"; |
14 | |
15 | $|=1; |
16 | |
55497cff |
17 | # catch warnings into fatal errors |
18 | $SIG{__WARN__} = sub { die "WARNING: @_" } ; |
c03358ae |
19 | $SIG{__DIE__} = sub { die @_ }; |
55497cff |
20 | |
49d42823 |
21 | undef $/; |
f0faabb7 |
22 | @prgs = split /^########\n/m, <DATA>; |
49d42823 |
23 | print "1..", scalar @prgs, "\n"; |
24 | |
25 | for (@prgs){ |
f0faabb7 |
26 | ++$i; |
27 | my($prog,$expected) = split(/\nEXPECT\n/, $_, 2); |
28 | print("not ok $i # bad test format\n"), next |
29 | unless defined $expected; |
96e82bbb |
30 | my ($testname) = $prog =~ /^\n?(# .*)\n/; |
f0faabb7 |
31 | $testname ||= ''; |
49d42823 |
32 | eval "$prog" ; |
33 | $status = $?; |
34 | $results = $@ ; |
35 | $results =~ s/\n+$//; |
36 | $expected =~ s/\n+$//; |
f0faabb7 |
37 | if ( $status || ($expected eq '') != ($results eq '') || |
38 | $results !~ /^(WARNING: )?$expected/){ |
49d42823 |
39 | print STDERR "STATUS: $status\n"; |
40 | print STDERR "PROG: $prog\n"; |
41 | print STDERR "EXPECTED:\n$expected\n"; |
42 | print STDERR "GOT:\n$results\n"; |
f0faabb7 |
43 | print "not ok $i $testname\n"; |
44 | } |
45 | else { |
46 | print "ok $i $testname\n"; |
49d42823 |
47 | } |
49d42823 |
48 | } |
49 | |
50 | __END__ |
51 | |
52 | # standard behaviour, without any extra references |
53 | use Tie::Hash ; |
54 | tie %h, Tie::StdHash; |
55 | untie %h; |
56 | EXPECT |
57 | ######## |
58 | |
a29a5827 |
59 | # standard behaviour, without any extra references |
60 | use Tie::Hash ; |
61 | {package Tie::HashUntie; |
62 | use base 'Tie::StdHash'; |
63 | sub UNTIE |
64 | { |
65 | warn "Untied\n"; |
66 | } |
67 | } |
68 | tie %h, Tie::HashUntie; |
69 | untie %h; |
70 | EXPECT |
71 | Untied |
72 | ######## |
73 | |
49d42823 |
74 | # standard behaviour, with 1 extra reference |
75 | use Tie::Hash ; |
76 | $a = tie %h, Tie::StdHash; |
77 | untie %h; |
78 | EXPECT |
79 | ######## |
80 | |
81 | # standard behaviour, with 1 extra reference via tied |
82 | use Tie::Hash ; |
83 | tie %h, Tie::StdHash; |
84 | $a = tied %h; |
85 | untie %h; |
86 | EXPECT |
87 | ######## |
88 | |
89 | # standard behaviour, with 1 extra reference which is destroyed |
90 | use Tie::Hash ; |
91 | $a = tie %h, Tie::StdHash; |
92 | $a = 0 ; |
93 | untie %h; |
94 | EXPECT |
95 | ######## |
96 | |
97 | # standard behaviour, with 1 extra reference via tied which is destroyed |
98 | use Tie::Hash ; |
99 | tie %h, Tie::StdHash; |
100 | $a = tied %h; |
101 | $a = 0 ; |
102 | untie %h; |
103 | EXPECT |
104 | ######## |
105 | |
106 | # strict behaviour, without any extra references |
4438c4b7 |
107 | use warnings 'untie'; |
49d42823 |
108 | use Tie::Hash ; |
109 | tie %h, Tie::StdHash; |
110 | untie %h; |
111 | EXPECT |
112 | ######## |
113 | |
114 | # strict behaviour, with 1 extra references generating an error |
4438c4b7 |
115 | use warnings 'untie'; |
49d42823 |
116 | use Tie::Hash ; |
117 | $a = tie %h, Tie::StdHash; |
118 | untie %h; |
119 | EXPECT |
55497cff |
120 | untie attempted while 1 inner references still exist |
49d42823 |
121 | ######## |
122 | |
123 | # strict behaviour, with 1 extra references via tied generating an error |
4438c4b7 |
124 | use warnings 'untie'; |
49d42823 |
125 | use Tie::Hash ; |
126 | tie %h, Tie::StdHash; |
127 | $a = tied %h; |
128 | untie %h; |
129 | EXPECT |
55497cff |
130 | untie attempted while 1 inner references still exist |
49d42823 |
131 | ######## |
132 | |
133 | # strict behaviour, with 1 extra references which are destroyed |
4438c4b7 |
134 | use warnings 'untie'; |
49d42823 |
135 | use Tie::Hash ; |
136 | $a = tie %h, Tie::StdHash; |
137 | $a = 0 ; |
138 | untie %h; |
139 | EXPECT |
140 | ######## |
141 | |
142 | # strict behaviour, with extra 1 references via tied which are destroyed |
4438c4b7 |
143 | use warnings 'untie'; |
49d42823 |
144 | use Tie::Hash ; |
145 | tie %h, Tie::StdHash; |
146 | $a = tied %h; |
147 | $a = 0 ; |
148 | untie %h; |
149 | EXPECT |
150 | ######## |
151 | |
152 | # strict error behaviour, with 2 extra references |
4438c4b7 |
153 | use warnings 'untie'; |
49d42823 |
154 | use Tie::Hash ; |
155 | $a = tie %h, Tie::StdHash; |
156 | $b = tied %h ; |
157 | untie %h; |
158 | EXPECT |
55497cff |
159 | untie attempted while 2 inner references still exist |
49d42823 |
160 | ######## |
161 | |
162 | # strict behaviour, check scope of strictness. |
4438c4b7 |
163 | no warnings 'untie'; |
49d42823 |
164 | use Tie::Hash ; |
165 | $A = tie %H, Tie::StdHash; |
166 | $C = $B = tied %H ; |
167 | { |
4438c4b7 |
168 | use warnings 'untie'; |
49d42823 |
169 | use Tie::Hash ; |
170 | tie %h, Tie::StdHash; |
171 | untie %h; |
172 | } |
173 | untie %H; |
174 | EXPECT |
33c27489 |
175 | ######## |
ae21d580 |
176 | # Forbidden aggregate self-ties |
33c27489 |
177 | sub Self::TIEHASH { bless $_[1], $_[0] } |
ae21d580 |
178 | { |
f0faabb7 |
179 | my %c; |
ae21d580 |
180 | tie %c, 'Self', \%c; |
181 | } |
182 | EXPECT |
183 | Self-ties of arrays and hashes are not supported |
184 | ######## |
185 | # Allowed scalar self-ties |
f0faabb7 |
186 | my $destroyed = 0; |
ae21d580 |
187 | sub Self::TIESCALAR { bless $_[1], $_[0] } |
f0faabb7 |
188 | sub Self::DESTROY { $destroyed = 1; } |
33c27489 |
189 | { |
ae21d580 |
190 | my $c = 42; |
ae21d580 |
191 | tie $c, 'Self', \$c; |
33c27489 |
192 | } |
f0faabb7 |
193 | die "self-tied scalar not DESTROYd" unless $destroyed == 1; |
194 | EXPECT |
195 | ######## |
196 | # Allowed glob self-ties |
197 | my $destroyed = 0; |
198 | sub Self2::TIEHANDLE { bless $_[1], $_[0] } |
199 | sub Self2::DESTROY { $destroyed = 1; } |
200 | { |
201 | use Symbol; |
202 | my $c = gensym; |
203 | tie *$c, 'Self2', $c; |
204 | } |
205 | die "self-tied glob not DESTROYd" unless $destroyed == 1; |
206 | EXPECT |
207 | ######## |
208 | # Allowed IO self-ties |
209 | my $destroyed = 0; |
210 | sub Self3::TIEHANDLE { bless $_[1], $_[0] } |
211 | sub Self3::DESTROY { $destroyed = 1; } |
212 | { |
213 | use Symbol 'geniosym'; |
214 | my $c = geniosym; |
215 | tie *$c, 'Self3', $c; |
216 | } |
217 | die "self-tied IO not DESTROYd" unless $destroyed == 1; |
33c27489 |
218 | EXPECT |
7bb043c3 |
219 | ######## |
220 | # Interaction of tie and vec |
221 | |
222 | my ($a, $b); |
223 | use Tie::Scalar; |
224 | tie $a,Tie::StdScalar or die; |
225 | vec($b,1,1)=1; |
226 | $a = $b; |
227 | vec($a,1,1)=0; |
228 | vec($b,1,1)=0; |
229 | die unless $a eq $b; |
230 | EXPECT |
83f527ec |
231 | ######## |
0b2c215a |
232 | # correct unlocalisation of tied hashes (patch #16431) |
233 | use Tie::Hash ; |
234 | tie %tied, Tie::StdHash; |
96e82bbb |
235 | { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; |
236 | { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; |
237 | { local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; |
0b2c215a |
238 | EXPECT |
239 | |