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