object never destructs

On Sun, 13 Jul 1997 11:20:24 EDT, Andrew Pimlott wrote:
>package mytest;
>sub DESTROY { warn "Death"; }
>package main;
>{
>    my $joe;
>	my $moe;
>	$moe = bless \$joe, 'mytest';
>	print "Leaving block\n";
>}
>print "Left block\n";

Thanks for that excellent test case.  Perl optimizes the
memory management of lexicals by not actually deallocating
unreferenced lexicals when the block exits, in order to
reuse them when the block is reentered.  This of course
fails to destruct objects at the end of blocks.

A patch that fixes the problem for all object datatypes
is attached.

p5p-msgid: 199707131955.PAA29655@aatma.engin.umich.edu

diff --git a/scope.c b/scope.c
index 0487ebe..98d99a4 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -536,7 +536,8 @@ I32 base;
        case SAVEt_CLEARSV:
            ptr = (void*)&curpad[SSPOPLONG];
            sv = *(SV**)ptr;
-           if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */
+           /* Can clear pad variable in place? */
+           if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
                if (SvTHINKFIRST(sv)) {
                    if (SvREADONLY(sv))
                        croak("panic: leave_scope clearsv");

diff --git a/t/op/ref.t b/t/op/ref.t
index 4e024d8..e83a04f 100755 (executable)
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..47\n";
+print "1..50\n";
 
 # Test glob operations.
 
@@ -207,12 +207,28 @@ print @baa == 3 ? "ok 42\n" : "not ok 42\n";
 print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n";
 print @bzz == 3 ? "ok 44\n" : "not ok 44\n";
 
+# test for proper destruction of lexical objects
+
+sub larry::DESTROY { print "# larry\nok 45\n"; }
+sub curly::DESTROY { print "# curly\nok 46\n"; }
+sub moe::DESTROY   { print "# moe\nok 47\n"; }
+
+{
+    my ($joe, @curly, %larry);
+    my $moe = bless \$joe, 'moe';
+    my $curly = bless \@curly, 'curly';
+    my $larry = bless \%larry, 'larry';
+    print "# leaving block\n";
+}
+
+print "# left block\n";
+
 package FINALE;
 
 {
-    $ref3 = bless ["ok 47\n"];         # package destruction
-    my $ref2 = bless ["ok 46\n"];      # lexical destruction
-    local $ref1 = bless ["ok 45\n"];   # dynamic destruction
+    $ref3 = bless ["ok 50\n"];         # package destruction
+    my $ref2 = bless ["ok 49\n"];      # lexical destruction
+    local $ref1 = bless ["ok 48\n"];   # dynamic destruction
     1;                                 # flush any temp values on stack
 }