Re: [PATCH] The largest hoax of all times?

Date: Tue, 5 Dec 2000 00:40:25 -0500
Message-ID: <20001205004025.A4050@monk.mps.ohio-state.edu>

Subject: Re: [PATCH] The largest hoax of all times?
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Date: Mon, 4 Dec 2000 23:55:53 -0500
Message-ID: <20001204235553.A1140@monk.mps.ohio-state.edu>

Subject: Re: [PATCH] The largest hoax of all times?
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Date: Tue, 5 Dec 2000 01:28:45 -0500
Message-ID: <20001205012844.A4227@monk.mps.ohio-state.edu>

Fix the unpredictable order of DESTROYs.

p4raw-id: //depot/perl@7991

9 files changed, 104 insertions, 20 deletions

diff --git a/embed.h b/embed.h
index 14dcbd7d14..6c90a54033 100644
--- a/embed.h
+++ b/embed.h
@@ -702,6 +702,7 @@
 #define sv_tainted		Perl_sv_tainted
 #define sv_unmagic		Perl_sv_unmagic
 #define sv_unref		Perl_sv_unref
+#define sv_unref_flags		Perl_sv_unref_flags
 #define sv_untaint		Perl_sv_untaint
 #define sv_upgrade		Perl_sv_upgrade
 #define sv_usepvn		Perl_sv_usepvn
@@ -819,6 +820,7 @@
 #define sv_utf8_encode		Perl_sv_utf8_encode
 #define sv_utf8_decode		Perl_sv_utf8_decode
 #define sv_force_normal		Perl_sv_force_normal
+#define sv_force_normal_flags	Perl_sv_force_normal_flags
 #define tmps_grow		Perl_tmps_grow
 #define sv_rvweaken		Perl_sv_rvweaken
 #define magic_killbackrefs	Perl_magic_killbackrefs
@@ -2165,6 +2167,7 @@
 #define sv_tainted(a)		Perl_sv_tainted(aTHX_ a)
 #define sv_unmagic(a,b)		Perl_sv_unmagic(aTHX_ a,b)
 #define sv_unref(a)		Perl_sv_unref(aTHX_ a)
+#define sv_unref_flags(a,b)	Perl_sv_unref_flags(aTHX_ a,b)
 #define sv_untaint(a)		Perl_sv_untaint(aTHX_ a)
 #define sv_upgrade(a,b)		Perl_sv_upgrade(aTHX_ a,b)
 #define sv_usepvn(a,b,c)	Perl_sv_usepvn(aTHX_ a,b,c)
@@ -2276,6 +2279,7 @@
 #define sv_utf8_encode(a)	Perl_sv_utf8_encode(aTHX_ a)
 #define sv_utf8_decode(a)	Perl_sv_utf8_decode(aTHX_ a)
 #define sv_force_normal(a)	Perl_sv_force_normal(aTHX_ a)
+#define sv_force_normal_flags(a,b)	Perl_sv_force_normal_flags(aTHX_ a,b)
 #define tmps_grow(a)		Perl_tmps_grow(aTHX_ a)
 #define sv_rvweaken(a)		Perl_sv_rvweaken(aTHX_ a)
 #define magic_killbackrefs(a,b)	Perl_magic_killbackrefs(aTHX_ a,b)
@@ -4246,6 +4250,8 @@
 #define sv_unmagic		Perl_sv_unmagic
 #define Perl_sv_unref		CPerlObj::Perl_sv_unref
 #define sv_unref		Perl_sv_unref
+#define Perl_sv_unref_flags	CPerlObj::Perl_sv_unref_flags
+#define sv_unref_flags		Perl_sv_unref_flags
 #define Perl_sv_untaint		CPerlObj::Perl_sv_untaint
 #define sv_untaint		Perl_sv_untaint
 #define Perl_sv_upgrade		CPerlObj::Perl_sv_upgrade
@@ -4463,6 +4469,8 @@
 #define sv_utf8_decode		Perl_sv_utf8_decode
 #define Perl_sv_force_normal	CPerlObj::Perl_sv_force_normal
 #define sv_force_normal		Perl_sv_force_normal
+#define Perl_sv_force_normal_flags	CPerlObj::Perl_sv_force_normal_flags
+#define sv_force_normal_flags	Perl_sv_force_normal_flags
 #define Perl_tmps_grow		CPerlObj::Perl_tmps_grow
 #define tmps_grow		Perl_tmps_grow
 #define Perl_sv_rvweaken	CPerlObj::Perl_sv_rvweaken
diff --git a/embed.pl b/embed.pl
index 055c28b963..ac43b0757d 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2042,6 +2042,7 @@ Ap	|void	|sv_taint	|SV* sv
 Ap	|bool	|sv_tainted	|SV* sv
 Apd	|int	|sv_unmagic	|SV* sv|int type
 Apd	|void	|sv_unref	|SV* sv
+Apd	|void	|sv_unref_flags	|SV* sv|U32 flags
 Ap	|void	|sv_untaint	|SV* sv
 Apd	|bool	|sv_upgrade	|SV* sv|U32 mt
 Apd	|void	|sv_usepvn	|SV* sv|char* ptr|STRLEN len
@@ -2170,6 +2171,7 @@ ApdM      |bool   |sv_utf8_downgrade|SV *sv|bool fail_ok
 ApdM      |void   |sv_utf8_encode |SV *sv
 Ap      |bool   |sv_utf8_decode |SV *sv
 Ap	|void	|sv_force_normal|SV *sv
+Ap	|void	|sv_force_normal_flags|SV *sv|U32 flags
 Ap	|void	|tmps_grow	|I32 n
 Apd	|SV*	|sv_rvweaken	|SV *sv
 p	|int	|magic_killbackrefs|SV *sv|MAGIC *mg
diff --git a/objXSUB.h b/objXSUB.h
index 91dc6df07c..5a3850cb4e 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1781,6 +1781,10 @@
 #define Perl_sv_unref		pPerl->Perl_sv_unref
 #undef  sv_unref
 #define sv_unref		Perl_sv_unref
+#undef  Perl_sv_unref_flags
+#define Perl_sv_unref_flags	pPerl->Perl_sv_unref_flags
+#undef  sv_unref_flags
+#define sv_unref_flags		Perl_sv_unref_flags
 #undef  Perl_sv_untaint
 #define Perl_sv_untaint		pPerl->Perl_sv_untaint
 #undef  sv_untaint
@@ -2138,6 +2142,10 @@
 #define Perl_sv_force_normal	pPerl->Perl_sv_force_normal
 #undef  sv_force_normal
 #define sv_force_normal		Perl_sv_force_normal
+#undef  Perl_sv_force_normal_flags
+#define Perl_sv_force_normal_flags	pPerl->Perl_sv_force_normal_flags
+#undef  sv_force_normal_flags
+#define sv_force_normal_flags	Perl_sv_force_normal_flags
 #undef  Perl_tmps_grow
 #define Perl_tmps_grow		pPerl->Perl_tmps_grow
 #undef  tmps_grow
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index e3e7479a23..f5b237f6db 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2368,19 +2368,19 @@ false, defined or undefined.  Does not handle 'get' magic.
 =for hackers
 Found in file sv.h
 
-=item SvTYPE
-
-Returns the type of the SV.  See C<svtype>.
+=item svtype
 
-	svtype	SvTYPE(SV* sv)
+An enum of flags for Perl types.  These are found in the file B<sv.h> 
+in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
 
 =for hackers
 Found in file sv.h
 
-=item svtype
+=item SvTYPE
 
-An enum of flags for Perl types.  These are found in the file B<sv.h> 
-in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV.  See C<svtype>.
+
+	svtype	SvTYPE(SV* sv)
 
 =for hackers
 Found in file sv.h
@@ -3063,13 +3063,29 @@ Found in file sv.c
 
 Unsets the RV status of the SV, and decrements the reference count of
 whatever was being referenced by the RV.  This can almost be thought of
-as a reversal of C<newSVrv>.  See C<SvROK_off>.
+as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with C<flag>
+of zero.  See C<SvROK_off>.  
 
 	void	sv_unref(SV* sv)
 
 =for hackers
 Found in file sv.c
 
+=item sv_unref_flags
+
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV.  This can almost be thought of
+as a reversal of C<newSVrv>.  The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.  
+
+	void	sv_unref_flags(SV* sv, U32 flags)
+
+=for hackers
+Found in file sv.c
+
 =item sv_upgrade
 
 Upgrade an SV to a more complex form.  Use C<SvUPGRADE>.  See
diff --git a/proto.h b/proto.h
index e561d1a024..1a3802ab47 100644
--- a/proto.h
+++ b/proto.h
@@ -782,6 +782,7 @@ PERL_CALLCONV void	Perl_sv_taint(pTHX_ SV* sv);
 PERL_CALLCONV bool	Perl_sv_tainted(pTHX_ SV* sv);
 PERL_CALLCONV int	Perl_sv_unmagic(pTHX_ SV* sv, int type);
 PERL_CALLCONV void	Perl_sv_unref(pTHX_ SV* sv);
+PERL_CALLCONV void	Perl_sv_unref_flags(pTHX_ SV* sv, U32 flags);
 PERL_CALLCONV void	Perl_sv_untaint(pTHX_ SV* sv);
 PERL_CALLCONV bool	Perl_sv_upgrade(pTHX_ SV* sv, U32 mt);
 PERL_CALLCONV void	Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len);
@@ -919,6 +920,7 @@ PERL_CALLCONV bool	Perl_sv_utf8_downgrade(pTHX_ SV *sv, bool fail_ok);
 PERL_CALLCONV void	Perl_sv_utf8_encode(pTHX_ SV *sv);
 PERL_CALLCONV bool	Perl_sv_utf8_decode(pTHX_ SV *sv);
 PERL_CALLCONV void	Perl_sv_force_normal(pTHX_ SV *sv);
+PERL_CALLCONV void	Perl_sv_force_normal_flags(pTHX_ SV *sv, U32 flags);
 PERL_CALLCONV void	Perl_tmps_grow(pTHX_ I32 n);
 PERL_CALLCONV SV*	Perl_sv_rvweaken(pTHX_ SV *sv);
 PERL_CALLCONV int	Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg);
diff --git a/scope.c b/scope.c
index 0713fa7e78..3f41a4e56b 100644
--- a/scope.c
+++ b/scope.c
@@ -809,7 +809,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    /* Can clear pad variable in place? */
 	    if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
 		if (SvTHINKFIRST(sv))
-		    sv_force_normal(sv);
+		    sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
 		if (SvMAGICAL(sv))
 		    mg_free(sv);
 
diff --git a/sv.c b/sv.c
index f875d58053..2691430787 100644
--- a/sv.c
+++ b/sv.c
@@ -3068,7 +3068,7 @@ Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len
 }
 
 void
-Perl_sv_force_normal(pTHX_ register SV *sv)
+Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
 {
     if (SvREADONLY(sv)) {
 	if (SvFAKE(sv)) {
@@ -3086,11 +3086,17 @@ Perl_sv_force_normal(pTHX_ register SV *sv)
 	    Perl_croak(aTHX_ PL_no_modify);
     }
     if (SvROK(sv))
-	sv_unref(sv);
+	sv_unref_flags(sv, flags);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
 	sv_unglob(sv);
 }
 
+void
+Perl_sv_force_normal(pTHX_ register SV *sv)
+{
+    sv_force_normal_flags(sv, 0);
+}
+
 /*
 =for apidoc sv_chop
 
@@ -5692,17 +5698,21 @@ S_sv_unglob(pTHX_ SV *sv)
 }
 
 /*
-=for apidoc sv_unref
+=for apidoc sv_unref_flags
 
 Unsets the RV status of the SV, and decrements the reference count of
 whatever was being referenced by the RV.  This can almost be thought of
-as a reversal of C<newSVrv>.  See C<SvROK_off>.
+as a reversal of C<newSVrv>.  The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.  
 
 =cut
 */
 
 void
-Perl_sv_unref(pTHX_ SV *sv)
+Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
 {
     SV* rv = SvRV(sv);
 
@@ -5714,12 +5724,29 @@ Perl_sv_unref(pTHX_ SV *sv)
     }
     SvRV(sv) = 0;
     SvROK_off(sv);
-    if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
+    if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
 	SvREFCNT_dec(rv);
-    else
+    else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
 	sv_2mortal(rv);		/* Schedule for freeing later */
 }
 
+/*
+=for apidoc sv_unref
+
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV.  This can almost be thought of
+as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
+being zero.  See C<SvROK_off>.  
+
+=cut
+*/
+
+void
+Perl_sv_unref(pTHX_ SV *sv)
+{
+    sv_unref_flags(sv, 0);
+}
+
 void
 Perl_sv_taint(pTHX_ SV *sv)
 {
diff --git a/sv.h b/sv.h
index b155ece7b0..39c1c29323 100644
--- a/sv.h
+++ b/sv.h
@@ -1096,3 +1096,4 @@ Returns a pointer to the character buffer.
 #define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
 #define Sv_Grow sv_grow
 
+#define SV_IMMEDIATE_UNREF	1
diff --git a/t/op/ref.t b/t/op/ref.t
index a2baab8e3b..8ae90424eb 100755
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..56\n";
+print "1..61\n";
 
 # Test glob operations.
 
@@ -279,14 +279,34 @@ print $$_,"\n";
     print ${\$_} for @a;
 }
 
+# This test is the reason for postponed destruction in sv_unref
+$a = [1,2,3];
+$a = $a->[1];
+print "not " unless $a == 2;
+print "ok 54\n";
+
+sub x::DESTROY {print "ok ", 54 + shift->[0], "\n"}
+{ my $a1 = bless [4],"x";
+  my $a2 = bless [3],"x";
+  { my $a3 = bless [2],"x";
+    my $a4 = bless [1],"x";
+    567;
+  }
+}
+
+
 # test global destruction
 
+my $test = 59;
+my $test1 = $test + 1;
+my $test2 = $test + 2;
+
 package FINALE;
 
 {
-    $ref3 = bless ["ok 56\n"];		# package destruction
-    my $ref2 = bless ["ok 55\n"];	# lexical destruction
-    local $ref1 = bless ["ok 54\n"];	# dynamic destruction
+    $ref3 = bless ["ok $test2\n"];	# package destruction
+    my $ref2 = bless ["ok $test1\n"];	# lexical destruction
+    local $ref1 = bless ["ok $test\n"];	# dynamic destruction
     1;					# flush any temp values on stack
 }