[win32] fix for bugs in handling DESTROY (adjusted test numbers)

	Message-Id: <199801010030.TAA14274@aatma.engin.umich.edu>
	Subject: Re: [PERL] RFD: iterative DESTROYing of objects

p4raw-id: //depot/win32/perl@490

diff --git a/pod/perlobj.pod b/pod/perlobj.pod
index 7428334..3d7bee8 100644 (file)
--- a/pod/perlobj.pod
+++ b/pod/perlobj.pod
@@ -331,14 +331,24 @@ automatically destroyed.  (This may even be after you exit, if you've
 stored references in global variables.)  If you want to capture control
 just before the object is freed, you may define a DESTROY method in
 your class.  It will automatically be called at the appropriate moment,
-and you can do any extra cleanup you need to do.
-
-Perl doesn't do nested destruction for you.  If your constructor
-re-blessed a reference from one of your base classes, your DESTROY may
-need to call DESTROY for any base classes that need it.  But this applies
-to only re-blessed objects--an object reference that is merely
-I<CONTAINED> in the current object will be freed and destroyed
-automatically when the current object is freed.
+and you can do any extra cleanup you need to do.  Perl passes a reference
+to the object under destruction as the first (and only) argument.  Beware
+that the reference is a read-only value, and cannot be modified by
+manipulating C<$_[0]> within the destructor.  The object itself (i.e.
+the thingy the reference points to, namely C<${$_[0]}>, C<@{$_[0]}>, 
+C<%{$_[0]}> etc.) is not similarly constrained.
+
+If you arrange to re-bless the reference before the destructor returns,
+perl will again call the DESTROY method for the re-blessed object after
+the current one returns.  This can be used for clean delegation of
+object destruction, or for ensuring that destructors in the base classes
+of your choosing get called.  Explicitly calling DESTROY is also possible,
+but is usually never needed.
+
+Do not confuse the foregoing with how objects I<CONTAINED> in the current
+one are destroyed.  Such objects will be freed and destroyed automatically
+when the current object is freed, provided no other references to them exist
+elsewhere.
 
 =head2 WARNING
 

diff --git a/sv.c b/sv.c
index 9de271b..f460e45 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2646,37 +2646,37 @@ sv_clear(register SV *sv)
        if (defstash) {         /* Still have a symbol table? */
            djSP;
            GV* destructor;
+           HV* stash;
+           SV ref;
 
-           ENTER;
-           SAVEFREESV(SvSTASH(sv));
-
-           destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
-           if (destructor) {
-               SV ref;
-
-               Zero(&ref, 1, SV);
-               sv_upgrade(&ref, SVt_RV);
-               SvRV(&ref) = SvREFCNT_inc(sv);
-               SvROK_on(&ref);
-               SvREFCNT(&ref) = 1;     /* Fake, but otherwise
-                                          creating+destructing a ref
-                                          leads to disaster. */
-
-               EXTEND(SP, 2);
-               PUSHMARK(SP);
-               PUSHs(&ref);
-               PUTBACK;
-               perl_call_sv((SV*)GvCV(destructor),
-                            G_DISCARD|G_EVAL|G_KEEPERR);
-               del_XRV(SvANY(&ref));
-               SvREFCNT(sv)--;
-           }
+           Zero(&ref, 1, SV);
+           sv_upgrade(&ref, SVt_RV);
+           SvROK_on(&ref);
+           SvREADONLY_on(&ref);        /* DESTROY() could be naughty */
+           SvREFCNT(&ref) = 1;
 
-           LEAVE;
+           do {
+               stash = SvSTASH(sv);
+               destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+               if (destructor) {
+                   ENTER;
+                   SvRV(&ref) = SvREFCNT_inc(sv);
+                   EXTEND(SP, 2);
+                   PUSHMARK(SP);
+                   PUSHs(&ref);
+                   PUTBACK;
+                   perl_call_sv((SV*)GvCV(destructor),
+                                G_DISCARD|G_EVAL|G_KEEPERR);
+                   SvREFCNT(sv)--;
+                   LEAVE;
+               }
+           } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+
+           del_XRV(SvANY(&ref));
        }
-       else
-           SvREFCNT_dec(SvSTASH(sv));
+
        if (SvOBJECT(sv)) {
+           SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
            SvOBJECT_off(sv);   /* Curse the object. */
            if (SvTYPE(sv) != SVt_PVIO)
                --sv_objcount;  /* XXX Might want something more general */

diff --git a/t/op/ref.t b/t/op/ref.t
index 5692517..1d70f9f 100755 (executable)
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..52\n";
+print "1..55\n";
 
 # Test glob operations.
 
@@ -235,12 +235,50 @@ $var = "ok 49";
 $_   = \$var;
 print $$_,"\n";
 
+# test if reblessing during destruction results in more destruction
+
+{
+    package A;
+    sub new { bless {}, shift }
+    DESTROY { print "# destroying 'A'\nok 51\n" }
+    package B;
+    sub new { bless {}, shift }
+    DESTROY { print "# destroying 'B'\nok 50\n"; bless shift, 'A' }
+    package main;
+    my $b = B->new;
+}
+
+# test if $_[0] is properly protected in DESTROY()
+
+{
+    my $i = 0;
+    local $SIG{'__DIE__'} = sub {
+       my $m = shift;
+       if ($i++ > 4) {
+           print "# infinite recursion, bailing\nnot ok 52\n";
+           exit 1;
+        }
+       print "# $m";
+       if ($m =~ /^Modification of a read-only/) { print "ok 52\n" }
+    };
+    package C;
+    sub new { bless {}, shift }
+    DESTROY { $_[0] = 'foo' }
+    {
+       print "# should generate an error...\n";
+       my $c = C->new;
+    }
+    print "# good, didn't recurse\n";
+}
+
+# test global destruction
+
 package FINALE;
 
 {
-    $ref3 = bless ["ok 52\n"];         # package destruction
-    my $ref2 = bless ["ok 51\n"];      # lexical destruction
-    local $ref1 = bless ["ok 50\n"];   # dynamic destruction
+    $ref3 = bless ["ok 55\n"];         # package destruction
+    my $ref2 = bless ["ok 54\n"];      # lexical destruction
+    local $ref1 = bless ["ok 53\n"];   # dynamic destruction
     1;                                 # flush any temp values on stack
 }