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