Commit | Line | Data |
---|---|---|
79072805 LW |
1 | #!./perl |
2 | ||
20274adc JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
b5fe401b | 5 | @INC = qw(. ../lib); |
20274adc JH |
6 | } |
7 | ||
b2ce0fda | 8 | require 'test.pl'; |
e24631be | 9 | use strict qw(refs subs); |
79072805 | 10 | |
fcf99ed4 | 11 | plan(189); |
805232b4 | 12 | |
79072805 LW |
13 | # Test glob operations. |
14 | ||
1c509eb9 NC |
15 | $bar = "one"; |
16 | $foo = "two"; | |
79072805 LW |
17 | { |
18 | local(*foo) = *bar; | |
1c509eb9 | 19 | is($foo, 'one'); |
79072805 | 20 | } |
1c509eb9 | 21 | is ($foo, 'two'); |
79072805 | 22 | |
1c509eb9 NC |
23 | $baz = "three"; |
24 | $foo = "four"; | |
79072805 LW |
25 | { |
26 | local(*foo) = 'baz'; | |
1c509eb9 | 27 | is ($foo, 'three'); |
79072805 | 28 | } |
1c509eb9 | 29 | is ($foo, 'four'); |
79072805 | 30 | |
1c509eb9 | 31 | $foo = "global"; |
79072805 LW |
32 | { |
33 | local(*foo); | |
1c509eb9 NC |
34 | is ($foo, undef); |
35 | $foo = "local"; | |
36 | is ($foo, 'local'); | |
79072805 | 37 | } |
1c509eb9 | 38 | is ($foo, 'global'); |
79072805 | 39 | |
e24631be NC |
40 | { |
41 | no strict 'refs'; | |
79072805 LW |
42 | # Test fake references. |
43 | ||
e24631be NC |
44 | $baz = "valid"; |
45 | $bar = 'baz'; | |
46 | $foo = 'bar'; | |
47 | is ($$$foo, 'valid'); | |
48 | } | |
79072805 LW |
49 | |
50 | # Test real references. | |
51 | ||
52 | $FOO = \$BAR; | |
53 | $BAR = \$BAZ; | |
1c509eb9 NC |
54 | $BAZ = "hit"; |
55 | is ($$$FOO, 'hit'); | |
79072805 LW |
56 | |
57 | # Test references to real arrays. | |
58 | ||
1c509eb9 NC |
59 | my $test = curr_test(); |
60 | @ary = ($test,$test+1,$test+2,$test+3); | |
79072805 LW |
61 | $ref[0] = \@a; |
62 | $ref[1] = \@b; | |
63 | $ref[2] = \@c; | |
64 | $ref[3] = \@d; | |
65 | for $i (3,1,2,0) { | |
66 | push(@{$ref[$i]}, "ok $ary[$i]\n"); | |
67 | } | |
68 | print @a; | |
69 | print ${$ref[1]}[0]; | |
70 | print @{$ref[2]}[0]; | |
e24631be NC |
71 | { |
72 | no strict 'refs'; | |
73 | print @{'d'}; | |
74 | } | |
1c509eb9 | 75 | curr_test($test+4); |
79072805 LW |
76 | |
77 | # Test references to references. | |
78 | ||
79 | $refref = \\$x; | |
1c509eb9 NC |
80 | $x = "Good"; |
81 | is ($$$refref, 'Good'); | |
79072805 LW |
82 | |
83 | # Test nested anonymous lists. | |
84 | ||
85 | $ref = [[],2,[3,4,5,]]; | |
1c509eb9 NC |
86 | is (scalar @$ref, 3); |
87 | is ($$ref[1], 2); | |
88 | is (${$$ref[2]}[2], 5); | |
89 | is (scalar @{$$ref[0]}, 0); | |
79072805 | 90 | |
1c509eb9 NC |
91 | is ($ref->[1], 2); |
92 | is ($ref->[2]->[0], 3); | |
79072805 LW |
93 | |
94 | # Test references to hashes of references. | |
95 | ||
96 | $refref = \%whatever; | |
97 | $refref->{"key"} = $ref; | |
1c509eb9 | 98 | is ($refref->{"key"}->[2]->[0], 3); |
79072805 | 99 | |
93a17b20 | 100 | # Test to see if anonymous subarrays spring into existence. |
79072805 LW |
101 | |
102 | $spring[5]->[0] = 123; | |
103 | $spring[5]->[1] = 456; | |
104 | push(@{$spring[5]}, 789); | |
1c509eb9 | 105 | is (join(':',@{$spring[5]}), "123:456:789"); |
79072805 | 106 | |
93a17b20 | 107 | # Test to see if anonymous subhashes spring into existence. |
79072805 LW |
108 | |
109 | @{$spring2{"foo"}} = (1,2,3); | |
110 | $spring2{"foo"}->[3] = 4; | |
1c509eb9 | 111 | is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); |
79072805 LW |
112 | |
113 | # Test references to subroutines. | |
114 | ||
1c509eb9 NC |
115 | { |
116 | my $called; | |
117 | sub mysub { $called++; } | |
118 | $subref = \&mysub; | |
119 | &$subref; | |
120 | is ($called, 1); | |
121 | } | |
79072805 LW |
122 | |
123 | $subrefref = \\&mysub2; | |
1c509eb9 NC |
124 | is ($$subrefref->("GOOD"), "good"); |
125 | sub mysub2 { lc shift } | |
79072805 LW |
126 | |
127 | # Test the ref operator. | |
128 | ||
6e592b3a BM |
129 | sub PVBM () { 'foo' } |
130 | { my $dummy = index 'foo', PVBM } | |
131 | ||
132 | my $pviv = 1; "$pviv"; | |
133 | my $pvnv = 1.0; "$pvnv"; | |
134 | my $x; | |
135 | ||
136 | # we don't test | |
137 | # tied lvalue => SCALAR, as we haven't tested tie yet | |
138 | # BIND, 'cos we can't create them yet | |
139 | # REGEXP, 'cos that requires overload or Scalar::Util | |
140 | # LVALUE ref, 'cos I can't work out how to create one :) | |
141 | ||
142 | for ( | |
143 | [ 'undef', SCALAR => \undef ], | |
144 | [ 'constant IV', SCALAR => \1 ], | |
145 | [ 'constant NV', SCALAR => \1.0 ], | |
146 | [ 'constant PV', SCALAR => \'f' ], | |
147 | [ 'scalar', SCALAR => \$x ], | |
148 | [ 'PVIV', SCALAR => \$pviv ], | |
149 | [ 'PVNV', SCALAR => \$pvnv ], | |
150 | [ 'PVMG', SCALAR => \$0 ], | |
151 | [ 'PVBM', SCALAR => \PVBM ], | |
152 | [ 'vstring', VSTRING => \v1 ], | |
153 | [ 'ref', REF => \\1 ], | |
154 | [ 'lvalue', LVALUE => \substr($x, 0, 0) ], | |
155 | [ 'named array', ARRAY => \@ary ], | |
156 | [ 'anon array', ARRAY => [ 1 ] ], | |
157 | [ 'named hash', HASH => \%whatever ], | |
158 | [ 'anon hash', HASH => { a => 1 } ], | |
159 | [ 'named sub', CODE => \&mysub, ], | |
160 | [ 'anon sub', CODE => sub { 1; } ], | |
161 | [ 'glob', GLOB => \*foo ], | |
162 | [ 'format', FORMAT => *STDERR{FORMAT} ], | |
163 | ) { | |
164 | my ($desc, $type, $ref) = @$_; | |
165 | is (ref $ref, $type, "ref() for ref to $desc"); | |
166 | like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); | |
167 | } | |
168 | ||
169 | is (ref *STDOUT{IO}, 'IO::Handle', 'IO refs are blessed into IO::Handle'); | |
170 | like (*STDOUT{IO}, qr/^IO::Handle=IO\(0x[0-9a-f]+\)$/, | |
171 | 'stringify for IO refs'); | |
79072805 LW |
172 | |
173 | # Test anonymous hash syntax. | |
174 | ||
175 | $anonhash = {}; | |
1c509eb9 | 176 | is (ref $anonhash, 'HASH'); |
e24631be | 177 | $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; |
1c509eb9 | 178 | is (join('', sort values %$anonhash2), 'BARXYZ'); |
79072805 LW |
179 | |
180 | # Test bless operator. | |
181 | ||
182 | package MYHASH; | |
183 | ||
184 | $object = bless $main'anonhash2; | |
1c509eb9 NC |
185 | main::is (ref $object, 'MYHASH'); |
186 | main::is ($object->{ABC}, 'XYZ'); | |
79072805 LW |
187 | |
188 | $object2 = bless {}; | |
1c509eb9 | 189 | main::is (ref $object2, 'MYHASH'); |
79072805 LW |
190 | |
191 | # Test ordinary call on object method. | |
192 | ||
1c509eb9 | 193 | &mymethod($object,"argument"); |
79072805 LW |
194 | |
195 | sub mymethod { | |
196 | local($THIS, @ARGS) = @_; | |
ed6116ce | 197 | die 'Got a "' . ref($THIS). '" instead of a MYHASH' |
e24631be | 198 | unless ref $THIS eq 'MYHASH'; |
1c509eb9 NC |
199 | main::is ($ARGS[0], "argument"); |
200 | main::is ($THIS->{FOO}, 'BAR'); | |
79072805 LW |
201 | } |
202 | ||
203 | # Test automatic destructor call. | |
204 | ||
1c509eb9 | 205 | $string = "bad"; |
79072805 | 206 | $object = "foo"; |
1c509eb9 | 207 | $string = "good"; |
79072805 | 208 | $main'anonhash2 = "foo"; |
8990e307 | 209 | $string = ""; |
79072805 | 210 | |
ed6116ce | 211 | DESTROY { |
8990e307 | 212 | return unless $string; |
1c509eb9 | 213 | main::is ($string, 'good'); |
79072805 | 214 | |
a0d0e21e | 215 | # Test that the object has not already been "cursed". |
1c509eb9 | 216 | main::isnt (ref shift, 'HASH'); |
79072805 LW |
217 | } |
218 | ||
219 | # Now test inheritance of methods. | |
220 | ||
221 | package OBJ; | |
222 | ||
e24631be | 223 | @ISA = ('BASEOBJ'); |
79072805 | 224 | |
e24631be | 225 | $main'object = bless {FOO => 'foo', BAR => 'bar'}; |
79072805 LW |
226 | |
227 | package main; | |
228 | ||
229 | # Test arrow-style method invocation. | |
230 | ||
e24631be | 231 | is ($object->doit("BAR"), 'bar'); |
79072805 LW |
232 | |
233 | # Test indirect-object-style method invocation. | |
234 | ||
235 | $foo = doit $object "FOO"; | |
e24631be | 236 | main::is ($foo, 'foo'); |
79072805 LW |
237 | |
238 | sub BASEOBJ'doit { | |
239 | local $ref = shift; | |
e24631be | 240 | die "Not an OBJ" unless ref $ref eq 'OBJ'; |
748a9306 | 241 | $ref->{shift()}; |
79072805 | 242 | } |
8990e307 | 243 | |
a0d0e21e LW |
244 | package UNIVERSAL; |
245 | @ISA = 'LASTCHANCE'; | |
246 | ||
247 | package LASTCHANCE; | |
805232b4 | 248 | sub foo { main::is ($_[1], 'works') } |
a0d0e21e LW |
249 | |
250 | package WHATEVER; | |
805232b4 | 251 | foo WHATEVER "works"; |
a0d0e21e | 252 | |
58e0a6ae GS |
253 | # |
254 | # test the \(@foo) construct | |
255 | # | |
256 | package main; | |
fb53bbb2 | 257 | @foo = \(1..3); |
58e0a6ae GS |
258 | @bar = \(@foo); |
259 | @baz = \(1,@foo,@bar); | |
805232b4 NC |
260 | is (scalar (@bar), 3); |
261 | is (scalar grep(ref($_), @bar), 3); | |
262 | is (scalar (@baz), 3); | |
58e0a6ae | 263 | |
fb53bbb2 | 264 | my(@fuu) = \(1..2,3); |
58e0a6ae GS |
265 | my(@baa) = \(@fuu); |
266 | my(@bzz) = \(1,@fuu,@baa); | |
805232b4 NC |
267 | is (scalar (@baa), 3); |
268 | is (scalar grep(ref($_), @baa), 3); | |
269 | is (scalar (@bzz), 3); | |
58e0a6ae | 270 | |
75ea820e SM |
271 | # also, it can't be an lvalue |
272 | eval '\\($x, $y) = (1, 2);'; | |
805232b4 | 273 | like ($@, qr/Can\'t modify.*ref.*in.*assignment/); |
75ea820e | 274 | |
bc44cdaf | 275 | # test for proper destruction of lexical objects |
1c509eb9 | 276 | $test = curr_test(); |
805232b4 NC |
277 | sub larry::DESTROY { print "# larry\nok $test\n"; } |
278 | sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } | |
279 | sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } | |
bc44cdaf GS |
280 | |
281 | { | |
282 | my ($joe, @curly, %larry); | |
283 | my $moe = bless \$joe, 'moe'; | |
284 | my $curly = bless \@curly, 'curly'; | |
285 | my $larry = bless \%larry, 'larry'; | |
286 | print "# leaving block\n"; | |
287 | } | |
288 | ||
289 | print "# left block\n"; | |
805232b4 | 290 | curr_test($test + 3); |
bc44cdaf | 291 | |
fb73857a | 292 | # another glob test |
293 | ||
805232b4 NC |
294 | |
295 | $foo = "garbage"; | |
fb73857a | 296 | { local(*bar) = "foo" } |
805232b4 | 297 | $bar = "glob 3"; |
fb73857a | 298 | local(*bar) = *bar; |
805232b4 | 299 | is ($bar, "glob 3"); |
fb73857a | 300 | |
805232b4 | 301 | $var = "glob 4"; |
d4010388 | 302 | $_ = \$var; |
805232b4 | 303 | is ($$_, 'glob 4'); |
d4010388 | 304 | |
4e8e7886 | 305 | |
805232b4 NC |
306 | # test if reblessing during destruction results in more destruction |
307 | $test = curr_test(); | |
4e8e7886 GS |
308 | { |
309 | package A; | |
310 | sub new { bless {}, shift } | |
805232b4 | 311 | DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } |
8bac7e00 | 312 | package _B; |
4e8e7886 | 313 | sub new { bless {}, shift } |
805232b4 | 314 | DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } |
4e8e7886 | 315 | package main; |
8bac7e00 | 316 | my $b = _B->new; |
4e8e7886 | 317 | } |
805232b4 | 318 | curr_test($test + 2); |
4e8e7886 GS |
319 | |
320 | # test if $_[0] is properly protected in DESTROY() | |
321 | ||
322 | { | |
805232b4 | 323 | my $test = curr_test(); |
4e8e7886 GS |
324 | my $i = 0; |
325 | local $SIG{'__DIE__'} = sub { | |
326 | my $m = shift; | |
327 | if ($i++ > 4) { | |
805232b4 | 328 | print "# infinite recursion, bailing\nnot ok $test\n"; |
4e8e7886 GS |
329 | exit 1; |
330 | } | |
805232b4 | 331 | like ($m, qr/^Modification of a read-only/); |
4e8e7886 GS |
332 | }; |
333 | package C; | |
334 | sub new { bless {}, shift } | |
335 | DESTROY { $_[0] = 'foo' } | |
336 | { | |
337 | print "# should generate an error...\n"; | |
338 | my $c = C->new; | |
339 | } | |
340 | print "# good, didn't recurse\n"; | |
341 | } | |
342 | ||
0dd88869 | 343 | # test if refgen behaves with autoviv magic |
0dd88869 GS |
344 | { |
345 | my @a; | |
805232b4 NC |
346 | $a[1] = "good"; |
347 | my $got; | |
348 | for (@a) { | |
349 | $got .= ${\$_}; | |
350 | $got .= ';'; | |
351 | } | |
352 | is ($got, ";good;"); | |
0dd88869 GS |
353 | } |
354 | ||
840a7b70 IZ |
355 | # This test is the reason for postponed destruction in sv_unref |
356 | $a = [1,2,3]; | |
357 | $a = $a->[1]; | |
805232b4 | 358 | is ($a, 2); |
840a7b70 | 359 | |
04ca4930 NC |
360 | # This test used to coredump. The BEGIN block is important as it causes the |
361 | # op that created the constant reference to be freed. Hence the only | |
362 | # reference to the constant string "pass" is in $a. The hack that made | |
363 | # sure $a = $a->[1] would work didn't work with references to constants. | |
364 | ||
04ca4930 NC |
365 | |
366 | foreach my $lexical ('', 'my $a; ') { | |
367 | my $expect = "pass\n"; | |
368 | my $result = runperl (switches => ['-wl'], stderr => 1, | |
369 | prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); | |
370 | ||
805232b4 NC |
371 | is ($?, 0); |
372 | is ($result, $expect); | |
840a7b70 IZ |
373 | } |
374 | ||
e24631be | 375 | $test = curr_test(); |
04ca4930 NC |
376 | sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} |
377 | { my $a1 = bless [3],"x"; | |
378 | my $a2 = bless [2],"x"; | |
379 | { my $a3 = bless [1],"x"; | |
380 | my $a4 = bless [0],"x"; | |
381 | 567; | |
382 | } | |
383 | } | |
805232b4 NC |
384 | curr_test($test+4); |
385 | ||
386 | is (runperl (switches=>['-l'], | |
387 | prog=> 'print 1; print qq-*$\*-;print 1;'), | |
388 | "1\n*\n*\n1\n"); | |
b2ce0fda | 389 | |
39cff0d9 AE |
390 | # bug #21347 |
391 | ||
392 | runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); | |
805232b4 | 393 | is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); |
39cff0d9 | 394 | |
7b102d90 | 395 | runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); |
805232b4 | 396 | is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); |
7b102d90 | 397 | |
23bb1b96 DM |
398 | |
399 | # bug #22719 | |
400 | ||
401 | runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); | |
805232b4 | 402 | is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); |
23bb1b96 | 403 | |
ec5f3c78 DM |
404 | # bug #27268: freeing self-referential typeglobs could trigger |
405 | # "Attempt to free unreferenced scalar" warnings | |
406 | ||
805232b4 | 407 | is (runperl( |
ec5f3c78 DM |
408 | prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x', |
409 | stderr => 1 | |
805232b4 | 410 | ), '', 'freeing self-referential typeglob'); |
23bb1b96 | 411 | |
804ffa60 DM |
412 | # using a regex in the destructor for STDOUT segfaulted because the |
413 | # REGEX pad had already been freed (ithreads build only). The | |
414 | # object is required to trigger the early freeing of GV refs to to STDOUT | |
415 | ||
805232b4 | 416 | like (runperl( |
804ffa60 DM |
417 | prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}', |
418 | stderr => 1 | |
805232b4 | 419 | ), qr/^(ok)+$/, 'STDOUT destructor'); |
804ffa60 | 420 | |
512d1826 NC |
421 | TODO: { |
422 | no strict 'refs'; | |
423 | $name8 = chr 163; | |
424 | $name_utf8 = $name8 . chr 256; | |
425 | chop $name_utf8; | |
426 | ||
427 | is ($$name8, undef, 'Nothing before we start'); | |
428 | is ($$name_utf8, undef, 'Nothing before we start'); | |
429 | $$name8 = "Pound"; | |
430 | is ($$name8, "Pound", 'Accessing via 8 bit symref works'); | |
431 | local $TODO = "UTF8 mangled in symrefs"; | |
432 | is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works'); | |
433 | } | |
434 | ||
435 | TODO: { | |
436 | no strict 'refs'; | |
437 | $name_utf8 = $name = chr 9787; | |
438 | utf8::encode $name_utf8; | |
439 | ||
440 | is (length $name, 1, "Name is 1 char"); | |
441 | is (length $name_utf8, 3, "UTF8 representation is 3 chars"); | |
442 | ||
443 | is ($$name, undef, 'Nothing before we start'); | |
444 | is ($$name_utf8, undef, 'Nothing before we start'); | |
445 | $$name = "Face"; | |
446 | is ($$name, "Face", 'Accessing via Unicode symref works'); | |
447 | local $TODO = "UTF8 mangled in symrefs"; | |
448 | is ($$name_utf8, undef, | |
449 | 'Accessing via the UTF8 byte sequence gives nothing'); | |
450 | } | |
451 | ||
431529db | 452 | { |
512d1826 NC |
453 | no strict 'refs'; |
454 | $name1 = "\0Chalk"; | |
455 | $name2 = "\0Cheese"; | |
456 | ||
457 | isnt ($name1, $name2, "They differ"); | |
458 | ||
431529db | 459 | is ($$name1, undef, 'Nothing before we start (scalars)'); |
512d1826 | 460 | is ($$name2, undef, 'Nothing before we start'); |
b3d904f3 | 461 | $$name1 = "Yummy"; |
512d1826 | 462 | is ($$name1, "Yummy", 'Accessing via the correct name works'); |
512d1826 NC |
463 | is ($$name2, undef, |
464 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
465 | # defined uses a different code path |
466 | ok (defined $$name1, 'defined via the correct name works'); | |
467 | ok (!defined $$name2, | |
468 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
469 | |
470 | is ($name1->[0], undef, 'Nothing before we start (arrays)'); | |
471 | is ($name2->[0], undef, 'Nothing before we start'); | |
472 | $name1->[0] = "Yummy"; | |
473 | is ($name1->[0], "Yummy", 'Accessing via the correct name works'); | |
474 | is ($name2->[0], undef, | |
475 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
476 | ok (defined $name1->[0], 'defined via the correct name works'); |
477 | ok (!defined$name2->[0], | |
478 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
479 | |
480 | my (undef, $one) = @{$name1}[2,3]; | |
481 | my (undef, $two) = @{$name2}[2,3]; | |
482 | is ($one, undef, 'Nothing before we start (array slices)'); | |
483 | is ($two, undef, 'Nothing before we start'); | |
484 | @{$name1}[2,3] = ("Very", "Yummy"); | |
485 | (undef, $one) = @{$name1}[2,3]; | |
486 | (undef, $two) = @{$name2}[2,3]; | |
487 | is ($one, "Yummy", 'Accessing via the correct name works'); | |
488 | is ($two, undef, | |
489 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
490 | ok (defined $one, 'defined via the correct name works'); |
491 | ok (!defined $two, | |
492 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
493 | |
494 | is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); | |
495 | is ($name2->{PWOF}, undef, 'Nothing before we start'); | |
496 | $name1->{PWOF} = "Yummy"; | |
497 | is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); | |
498 | is ($name2->{PWOF}, undef, | |
499 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
500 | ok (defined $name1->{PWOF}, 'defined via the correct name works'); |
501 | ok (!defined $name2->{PWOF}, | |
502 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
503 | |
504 | my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; | |
505 | my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; | |
506 | is ($one, undef, 'Nothing before we start (hash slices)'); | |
507 | is ($two, undef, 'Nothing before we start'); | |
508 | @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy"); | |
509 | (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; | |
510 | (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; | |
511 | is ($one, "Yummy", 'Accessing via the correct name works'); | |
512 | is ($two, undef, | |
513 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
514 | ok (defined $one, 'defined via the correct name works'); |
515 | ok (!defined $two, | |
516 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
517 | |
518 | $name1 = "Left"; $name2 = "Left\0Right"; | |
519 | my $glob2 = *{$name2}; | |
520 | ||
88e5f542 | 521 | is ($glob1, undef, "We get different typeglobs. In fact, undef"); |
780a5241 NC |
522 | |
523 | *{$name1} = sub {"One"}; | |
524 | *{$name2} = sub {"Two"}; | |
525 | ||
526 | is (&{$name1}, "One"); | |
527 | is (&{$name2}, "Two"); | |
512d1826 NC |
528 | } |
529 | ||
9a9798c2 YST |
530 | # test derefs after list slice |
531 | ||
532 | is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' ); | |
533 | is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' ); | |
534 | is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' ); | |
535 | is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' ); | |
536 | is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' ); | |
537 | is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); | |
538 | ||
539 | # deref on empty list shouldn't autovivify | |
540 | { | |
541 | local $@; | |
542 | eval { ()[0]{foo} }; | |
543 | like ( "$@", "Can't use an undefined value as a HASH reference", | |
544 | "deref of undef from list slice fails" ); | |
545 | } | |
546 | ||
cbae9b9f YST |
547 | # test dereferencing errors |
548 | { | |
2d905216 NC |
549 | format STDERR = |
550 | . | |
551 | my $ref; | |
552 | foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { | |
553 | eval q/ $$ref /; | |
554 | like($@, qr/Not a SCALAR reference/, "Scalar dereference"); | |
555 | eval q/ @$ref /; | |
556 | like($@, qr/Not an ARRAY reference/, "Array dereference"); | |
557 | eval q/ %$ref /; | |
558 | like($@, qr/Not a HASH reference/, "Hash dereference"); | |
559 | eval q/ &$ref /; | |
560 | like($@, qr/Not a CODE reference/, "Code dereference"); | |
561 | } | |
562 | ||
563 | $ref = *STDERR{FORMAT}; | |
564 | eval q/ *$ref /; | |
565 | like($@, qr/Not a GLOB reference/, "Glob dereference"); | |
566 | ||
567 | $ref = *STDOUT{IO}; | |
568 | eval q/ *$ref /; | |
569 | is($@, '', "Glob dereference of PVIO is acceptable"); | |
570 | ||
571 | is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); | |
cbae9b9f YST |
572 | } |
573 | ||
6e592b3a BM |
574 | # these will segfault if they fail |
575 | ||
576 | my $pvbm = PVBM; | |
577 | my $rpvbm = \$pvbm; | |
578 | ||
579 | ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); | |
580 | ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); | |
581 | ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); | |
582 | ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); | |
583 | ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); | |
584 | ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); | |
585 | ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); | |
586 | ||
fcf99ed4 B |
587 | # bug 24254 |
588 | is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); | |
589 | is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); | |
590 | is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); | |
591 | is( runperl(stderr => 1, prog => 'map die,4 for 3'), "Died at -e line 1.\n"); | |
592 | is( runperl(stderr => 1, prog => 'grep die,4 for 3'), "Died at -e line 1.\n"); | |
593 | is( runperl(stderr => 1, prog => 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); | |
594 | ||
595 | # bug 57564 | |
596 | is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); | |
597 | ||
598 | ||
805232b4 NC |
599 | # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. |
600 | $test = curr_test(); | |
601 | curr_test($test + 3); | |
4e8e7886 GS |
602 | # test global destruction |
603 | ||
840a7b70 IZ |
604 | my $test1 = $test + 1; |
605 | my $test2 = $test + 2; | |
606 | ||
8990e307 LW |
607 | package FINALE; |
608 | ||
609 | { | |
840a7b70 IZ |
610 | $ref3 = bless ["ok $test2\n"]; # package destruction |
611 | my $ref2 = bless ["ok $test1\n"]; # lexical destruction | |
612 | local $ref1 = bless ["ok $test\n"]; # dynamic destruction | |
8990e307 LW |
613 | 1; # flush any temp values on stack |
614 | } | |
615 | ||
616 | DESTROY { | |
617 | print $_[0][0]; | |
618 | } | |
804ffa60 | 619 |