Commit | Line | Data |
---|---|---|
49d42823 | 1 | #!./perl |
2 | ||
96e82bbb YST |
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 YST |
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 YST |
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 YST |
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 NIS |
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 JH |
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 YST |
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 IP |
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 JH |
232 | # correct unlocalisation of tied hashes (patch #16431) |
233 | use Tie::Hash ; | |
234 | tie %tied, Tie::StdHash; | |
96e82bbb YST |
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 JH |
238 | EXPECT |
239 |