Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.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(138);
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     # defined uses a different code path
431     ok (defined $$name1, 'defined via the correct name works');
432     ok (!defined $$name2,
433         'defined via a different NUL-containing name gives nothing');
434
435     is ($name1->[0], undef, 'Nothing before we start (arrays)');
436     is ($name2->[0], undef, 'Nothing before we start');
437     $name1->[0] = "Yummy";
438     is ($name1->[0], "Yummy", 'Accessing via the correct name works');
439     is ($name2->[0], undef,
440         'Accessing via a different NUL-containing name gives nothing');
441     ok (defined $name1->[0], 'defined via the correct name works');
442     ok (!defined$name2->[0],
443         'defined via a different NUL-containing name gives nothing');
444
445     my (undef, $one) = @{$name1}[2,3];
446     my (undef, $two) = @{$name2}[2,3];
447     is ($one, undef, 'Nothing before we start (array slices)');
448     is ($two, undef, 'Nothing before we start');
449     @{$name1}[2,3] = ("Very", "Yummy");
450     (undef, $one) = @{$name1}[2,3];
451     (undef, $two) = @{$name2}[2,3];
452     is ($one, "Yummy", 'Accessing via the correct name works');
453     is ($two, undef,
454         'Accessing via a different NUL-containing name gives nothing');
455     ok (defined $one, 'defined via the correct name works');
456     ok (!defined $two,
457         'defined via a different NUL-containing name gives nothing');
458
459     is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)');
460     is ($name2->{PWOF}, undef, 'Nothing before we start');
461     $name1->{PWOF} = "Yummy";
462     is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works');
463     is ($name2->{PWOF}, undef,
464         'Accessing via a different NUL-containing name gives nothing');
465     ok (defined $name1->{PWOF}, 'defined via the correct name works');
466     ok (!defined $name2->{PWOF},
467         'defined via a different NUL-containing name gives nothing');
468
469     my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
470     my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
471     is ($one, undef, 'Nothing before we start (hash slices)');
472     is ($two, undef, 'Nothing before we start');
473     @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy");
474     (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'};
475     (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'};
476     is ($one, "Yummy", 'Accessing via the correct name works');
477     is ($two, undef,
478         'Accessing via a different NUL-containing name gives nothing');
479     ok (defined $one, 'defined via the correct name works');
480     ok (!defined $two,
481         'defined via a different NUL-containing name gives nothing');
482
483     $name1 = "Left"; $name2 = "Left\0Right";
484     my $glob2 = *{$name2};
485
486     is ($glob1, undef, "We get different typeglobs. In fact, undef");
487
488     *{$name1} = sub {"One"};
489     *{$name2} = sub {"Two"};
490
491     is (&{$name1}, "One");
492     is (&{$name2}, "Two");
493 }
494
495 # test derefs after list slice
496
497 is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' );
498 is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' );
499 is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' );
500 is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' );
501 is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' );
502 is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
503
504 # deref on empty list shouldn't autovivify
505 {
506     local $@;
507     eval { ()[0]{foo} };
508     like ( "$@", "Can't use an undefined value as a HASH reference",
509            "deref of undef from list slice fails" );
510 }
511
512 # test dereferencing errors
513 {
514     format STDERR =
515 .
516     my $ref;
517     foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
518         eval q/ $$ref /;
519         like($@, qr/Not a SCALAR reference/, "Scalar dereference");
520         eval q/ @$ref /;
521         like($@, qr/Not an ARRAY reference/, "Array dereference");
522         eval q/ %$ref /;
523         like($@, qr/Not a HASH reference/, "Hash dereference");
524         eval q/ &$ref /;
525         like($@, qr/Not a CODE reference/, "Code dereference");
526     }
527
528     $ref = *STDERR{FORMAT};
529     eval q/ *$ref /;
530     like($@, qr/Not a GLOB reference/, "Glob dereference");
531
532     $ref = *STDOUT{IO};
533     eval q/ *$ref /;
534     is($@, '', "Glob dereference of PVIO is acceptable");
535
536     is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly");
537 }
538
539 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
540 $test = curr_test();
541 curr_test($test + 3);
542 # test global destruction
543
544 my $test1 = $test + 1;
545 my $test2 = $test + 2;
546
547 package FINALE;
548
549 {
550     $ref3 = bless ["ok $test2\n"];      # package destruction
551     my $ref2 = bless ["ok $test1\n"];   # lexical destruction
552     local $ref1 = bless ["ok $test\n"]; # dynamic destruction
553     1;                                  # flush any temp values on stack
554 }
555
556 DESTROY {
557     print $_[0][0];
558 }
559