Commit | Line | Data |
---|---|---|
49d42823 | 1 | #!./perl |
2 | ||
924d8646 CN |
3 | # Add new tests to the end with format: |
4 | # ######## | |
5 | # | |
6 | # # test description | |
7 | # Test code | |
8 | # EXPECT | |
9 | # Warn or die msgs (if any) at - line 1234 | |
10 | # | |
49d42823 | 11 | |
12 | chdir 't' if -d 't'; | |
20822f61 | 13 | @INC = '../lib'; |
49d42823 | 14 | $ENV{PERL5LIB} = "../lib"; |
15 | ||
16 | $|=1; | |
17 | ||
18 | undef $/; | |
924d8646 | 19 | @prgs = split /^########\n/m, <DATA>; |
49d42823 | 20 | |
924d8646 CN |
21 | require './test.pl'; |
22 | plan(tests => scalar @prgs); | |
49d42823 | 23 | for (@prgs){ |
924d8646 CN |
24 | ++$i; |
25 | my($prog,$expected) = split(/\nEXPECT\n/, $_, 2); | |
26 | print("not ok $i # bad test format\n"), next | |
27 | unless defined $expected; | |
28 | my ($testname) = $prog =~ /^# (.*)\n/m; | |
29 | $testname ||= ''; | |
30 | $TODO = $testname =~ s/^TODO //; | |
49d42823 | 31 | $results =~ s/\n+$//; |
32 | $expected =~ s/\n+$//; | |
924d8646 CN |
33 | |
34 | fresh_perl_is($prog, $expected, {}, $testname); | |
49d42823 | 35 | } |
36 | ||
37 | __END__ | |
38 | ||
39 | # standard behaviour, without any extra references | |
40 | use Tie::Hash ; | |
41 | tie %h, Tie::StdHash; | |
42 | untie %h; | |
43 | EXPECT | |
44 | ######## | |
45 | ||
a29a5827 NIS |
46 | # standard behaviour, without any extra references |
47 | use Tie::Hash ; | |
48 | {package Tie::HashUntie; | |
49 | use base 'Tie::StdHash'; | |
50 | sub UNTIE | |
51 | { | |
52 | warn "Untied\n"; | |
53 | } | |
54 | } | |
55 | tie %h, Tie::HashUntie; | |
56 | untie %h; | |
57 | EXPECT | |
58 | Untied | |
59 | ######## | |
60 | ||
49d42823 | 61 | # standard behaviour, with 1 extra reference |
62 | use Tie::Hash ; | |
63 | $a = tie %h, Tie::StdHash; | |
64 | untie %h; | |
65 | EXPECT | |
66 | ######## | |
67 | ||
68 | # standard behaviour, with 1 extra reference via tied | |
69 | use Tie::Hash ; | |
70 | tie %h, Tie::StdHash; | |
71 | $a = tied %h; | |
72 | untie %h; | |
73 | EXPECT | |
74 | ######## | |
75 | ||
76 | # standard behaviour, with 1 extra reference which is destroyed | |
77 | use Tie::Hash ; | |
78 | $a = tie %h, Tie::StdHash; | |
79 | $a = 0 ; | |
80 | untie %h; | |
81 | EXPECT | |
82 | ######## | |
83 | ||
84 | # standard behaviour, with 1 extra reference via tied which is destroyed | |
85 | use Tie::Hash ; | |
86 | tie %h, Tie::StdHash; | |
87 | $a = tied %h; | |
88 | $a = 0 ; | |
89 | untie %h; | |
90 | EXPECT | |
91 | ######## | |
92 | ||
93 | # strict behaviour, without any extra references | |
4438c4b7 | 94 | use warnings 'untie'; |
49d42823 | 95 | use Tie::Hash ; |
96 | tie %h, Tie::StdHash; | |
97 | untie %h; | |
98 | EXPECT | |
99 | ######## | |
100 | ||
101 | # strict behaviour, with 1 extra references generating an error | |
4438c4b7 | 102 | use warnings 'untie'; |
49d42823 | 103 | use Tie::Hash ; |
104 | $a = tie %h, Tie::StdHash; | |
105 | untie %h; | |
106 | EXPECT | |
924d8646 | 107 | untie attempted while 1 inner references still exist at - line 6. |
49d42823 | 108 | ######## |
109 | ||
110 | # strict behaviour, with 1 extra references via tied generating an error | |
4438c4b7 | 111 | use warnings 'untie'; |
49d42823 | 112 | use Tie::Hash ; |
113 | tie %h, Tie::StdHash; | |
114 | $a = tied %h; | |
115 | untie %h; | |
116 | EXPECT | |
924d8646 | 117 | untie attempted while 1 inner references still exist at - line 7. |
49d42823 | 118 | ######## |
119 | ||
120 | # strict behaviour, with 1 extra references which are destroyed | |
4438c4b7 | 121 | use warnings 'untie'; |
49d42823 | 122 | use Tie::Hash ; |
123 | $a = tie %h, Tie::StdHash; | |
124 | $a = 0 ; | |
125 | untie %h; | |
126 | EXPECT | |
127 | ######## | |
128 | ||
129 | # strict behaviour, with extra 1 references via tied which are destroyed | |
4438c4b7 | 130 | use warnings 'untie'; |
49d42823 | 131 | use Tie::Hash ; |
132 | tie %h, Tie::StdHash; | |
133 | $a = tied %h; | |
134 | $a = 0 ; | |
135 | untie %h; | |
136 | EXPECT | |
137 | ######## | |
138 | ||
498ea806 | 139 | # strict error behaviour, with 2 extra references |
4438c4b7 | 140 | use warnings 'untie'; |
49d42823 | 141 | use Tie::Hash ; |
142 | $a = tie %h, Tie::StdHash; | |
143 | $b = tied %h ; | |
144 | untie %h; | |
145 | EXPECT | |
924d8646 | 146 | untie attempted while 2 inner references still exist at - line 7. |
49d42823 | 147 | ######## |
148 | ||
149 | # strict behaviour, check scope of strictness. | |
4438c4b7 | 150 | no warnings 'untie'; |
49d42823 | 151 | use Tie::Hash ; |
152 | $A = tie %H, Tie::StdHash; | |
153 | $C = $B = tied %H ; | |
154 | { | |
4438c4b7 | 155 | use warnings 'untie'; |
49d42823 | 156 | use Tie::Hash ; |
157 | tie %h, Tie::StdHash; | |
158 | untie %h; | |
159 | } | |
160 | untie %H; | |
161 | EXPECT | |
33c27489 | 162 | ######## |
924d8646 | 163 | |
ae21d580 | 164 | # Forbidden aggregate self-ties |
33c27489 | 165 | sub Self::TIEHASH { bless $_[1], $_[0] } |
ae21d580 | 166 | { |
924d8646 | 167 | my %c; |
ae21d580 JH |
168 | tie %c, 'Self', \%c; |
169 | } | |
170 | EXPECT | |
924d8646 | 171 | Self-ties of arrays and hashes are not supported at - line 6. |
ae21d580 | 172 | ######## |
924d8646 | 173 | |
ae21d580 | 174 | # Allowed scalar self-ties |
924d8646 | 175 | my $destroyed = 0; |
ae21d580 | 176 | sub Self::TIESCALAR { bless $_[1], $_[0] } |
924d8646 | 177 | sub Self::DESTROY { $destroyed = 1; } |
33c27489 | 178 | { |
ae21d580 | 179 | my $c = 42; |
ae21d580 | 180 | tie $c, 'Self', \$c; |
33c27489 | 181 | } |
924d8646 | 182 | die "self-tied scalar not DESTROYed" unless $destroyed == 1; |
bee2c548 CN |
183 | EXPECT |
184 | ######## | |
0358cc2c | 185 | |
924d8646 | 186 | # TODO Allowed glob self-ties |
bee2c548 | 187 | my $destroyed = 0; |
498ea806 | 188 | my $printed = 0; |
bee2c548 CN |
189 | sub Self2::TIEHANDLE { bless $_[1], $_[0] } |
190 | sub Self2::DESTROY { $destroyed = 1; } | |
498ea806 | 191 | sub Self2::PRINT { $printed = 1; } |
bee2c548 CN |
192 | { |
193 | use Symbol; | |
194 | my $c = gensym; | |
195 | tie *$c, 'Self2', $c; | |
498ea806 | 196 | print $c 'Hello'; |
bee2c548 | 197 | } |
498ea806 CN |
198 | die "self-tied glob not PRINTed" unless $printed == 1; |
199 | die "self-tied glob not DESTROYed" unless $destroyed == 1; | |
bee2c548 CN |
200 | EXPECT |
201 | ######## | |
0358cc2c | 202 | |
bee2c548 CN |
203 | # Allowed IO self-ties |
204 | my $destroyed = 0; | |
205 | sub Self3::TIEHANDLE { bless $_[1], $_[0] } | |
206 | sub Self3::DESTROY { $destroyed = 1; } | |
207 | { | |
208 | use Symbol 'geniosym'; | |
209 | my $c = geniosym; | |
210 | tie *$c, 'Self3', $c; | |
211 | } | |
498ea806 | 212 | die "self-tied IO not DESTROYed" unless $destroyed == 1; |
62822184 | 213 | EXPECT |
0358cc2c | 214 | ######## |
62822184 | 215 | |
924d8646 CN |
216 | # Interaction of tie and vec |
217 | ||
218 | my ($a, $b); | |
219 | use Tie::Scalar; | |
220 | tie $a,Tie::StdScalar or die; | |
221 | vec($b,1,1)=1; | |
222 | $a = $b; | |
223 | vec($a,1,1)=0; | |
224 | vec($b,1,1)=0; | |
225 | die unless $a eq $b; | |
226 | EXPECT | |
227 | ######## | |
228 | ||
229 | # correct unlocalisation of tied hashes (patch #16431) | |
230 | use Tie::Hash ; | |
231 | tie %tied, Tie::StdHash; | |
232 | { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; | |
233 | { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; | |
234 | { local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; | |
235 | EXPECT | |
236 | ######## | |
237 | ||
238 | # An attempt at lvalueable barewords broke this | |
239 | tie FH, 'main'; | |
240 | EXPECT | |
241 | Can't modify constant item in tie at - line 3, near "'main';" | |
242 | Execution of - aborted due to compilation errors. | |
3541f8c8 CN |
243 | ######## |
244 | ||
245 | # localizing tied hash slices | |
246 | $ENV{FooA} = 1; | |
247 | $ENV{FooB} = 2; | |
248 | print exists $ENV{FooA} ? 1 : 0, "\n"; | |
249 | print exists $ENV{FooB} ? 2 : 0, "\n"; | |
250 | print exists $ENV{FooC} ? 3 : 0, "\n"; | |
251 | { | |
252 | local @ENV{qw(FooA FooC)}; | |
253 | print exists $ENV{FooA} ? 4 : 0, "\n"; | |
254 | print exists $ENV{FooB} ? 5 : 0, "\n"; | |
255 | print exists $ENV{FooC} ? 6 : 0, "\n"; | |
256 | } | |
257 | print exists $ENV{FooA} ? 7 : 0, "\n"; | |
258 | print exists $ENV{FooB} ? 8 : 0, "\n"; | |
259 | print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist | |
260 | EXPECT | |
261 | 1 | |
262 | 2 | |
263 | 0 | |
264 | 4 | |
265 | 5 | |
266 | 6 | |
267 | 7 | |
268 | 8 | |
269 | 0 |