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