"Fix PERL_DESTRUCT_LEVEL core dumps"

Msg-ID:  <199805062301.TAA24599@aatma.engin.umich.edu>
 Files:  perl.c sv.c t/op/misc.t

p4raw-id: //depot/maint-5.004/perl@946

3 files changed, 75 insertions, 7 deletions

diff --git a/perl.c b/perl.c
index 4ce6a0a1df..7b41bfe448 100644
--- a/perl.c
+++ b/perl.c
@@ -135,6 +135,7 @@ register PerlInterpreter *sv_interp;
 #endif
     }
 
+    init_stacks();
 #ifdef MULTIPLICITY
     I_REINIT;
     perl_destruct_level = 1; 
@@ -170,7 +171,6 @@ register PerlInterpreter *sv_interp;
 
     fdpid = newAV();	/* for remembering popen pids by fd */
 
-    init_stacks();
     ENTER;
 }
 
diff --git a/sv.c b/sv.c
index f6a8fa4511..10e80b6fb3 100644
--- a/sv.c
+++ b/sv.c
@@ -325,8 +325,19 @@ static void
 do_clean_named_objs(sv)
 SV* sv;
 {
-    if (SvTYPE(sv) == SVt_PVGV && GvSV(sv))
-	do_clean_objs(GvSV(sv));
+    if (SvTYPE(sv) == SVt_PVGV) {
+	if ( SvOBJECT(GvSV(sv)) ||
+	     GvAV(sv) && SvOBJECT(GvAV(sv)) ||
+	     GvHV(sv) && SvOBJECT(GvHV(sv)) ||
+	     GvIO(sv) && SvOBJECT(GvIO(sv)) ||
+	     GvCV(sv) && SvOBJECT(GvCV(sv)) )
+	{
+	    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
+	    SvREFCNT_dec(sv);
+	}
+	else if (GvSV(sv))
+	    do_clean_objs(GvSV(sv));
+    }
 }
 #endif
 
@@ -2774,6 +2785,7 @@ void
 sv_clear(sv)
 register SV *sv;
 {
+    HV* stash;
     assert(sv);
     assert(SvREFCNT(sv) == 0);
 
@@ -2781,7 +2793,6 @@ register SV *sv;
 	if (defstash) {		/* Still have a symbol table? */
 	    dSP;
 	    GV* destructor;
-	    HV* stash;
 	    SV ref;
 
 	    Zero(&ref, 1, SV);
@@ -2825,6 +2836,7 @@ register SV *sv;
     }
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
 	mg_free(sv);
+    stash = NULL;
     switch (SvTYPE(sv)) {
     case SVt_PVIO:
 	if (IoIFP(sv) != PerlIO_stdin() &&
@@ -2850,7 +2862,11 @@ register SV *sv;
     case SVt_PVGV:
 	gp_free((GV*)sv);
 	Safefree(GvNAME(sv));
-	SvREFCNT_dec(GvSTASH(sv));
+	/* cannot decrease stash refcount yet, as we might recursively delete
+	   ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
+	   of stash until current sv is completely gone.
+	   -- JohnPC, 27 Mar 1998 */
+	stash = GvSTASH(sv);
 	/* FALL THROUGH */
     case SVt_PVLV:
     case SVt_PVMG:
@@ -2912,7 +2928,13 @@ register SV *sv;
 	break;
     case SVt_PVGV:
 	del_XPVGV(SvANY(sv));
-	break;
+	/* code duplication for increased performance. */
+	SvFLAGS(sv) &= SVf_BREAK;
+	SvFLAGS(sv) |= SVTYPEMASK;
+	/* decrease refcount of the stash that owns this GV, if any */
+	if (stash)
+	    SvREFCNT_dec(stash);
+	return; /* not break, SvFLAGS reset already happened */
     case SVt_PVBM:
 	del_XPVBM(SvANY(sv));
 	break;
@@ -5127,7 +5149,8 @@ SV* sv;
     case SVt_PVGV:
 	PerlIO_printf(Perl_debug_log, "  NAME = \"%s\"\n", GvNAME(sv));
 	PerlIO_printf(Perl_debug_log, "  NAMELEN = %ld\n", (long)GvNAMELEN(sv));
-	PerlIO_printf(Perl_debug_log, "  STASH = \"%s\"\n", HvNAME(GvSTASH(sv)));
+	PerlIO_printf(Perl_debug_log, "  STASH = \"%s\"\n",
+	    SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)");
 	PerlIO_printf(Perl_debug_log, "  GP = 0x%lx\n", (long)GvGP(sv));
 	PerlIO_printf(Perl_debug_log, "    SV = 0x%lx\n", (long)GvSV(sv));
 	PerlIO_printf(Perl_debug_log, "    REFCNT = %ld\n", (long)GvREFCNT(sv));
diff --git a/t/op/misc.t b/t/op/misc.t
index 1fdbefd991..34fc885176 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -359,3 +359,48 @@ EXPECT
 sub testme { my $a = "test"; { local $a = "new test"; print $a }}
 EXPECT
 Can't localize lexical variable $a at - line 2.
+########
+package X;
+sub ascalar { my $r; bless \$r }
+sub DESTROY { print "destroyed\n" };
+package main;
+*s = ascalar X;
+EXPECT
+destroyed
+########
+package X;
+sub anarray { bless [] }
+sub DESTROY { print "destroyed\n" };
+package main;
+*a = anarray X;
+EXPECT
+destroyed
+########
+package X;
+sub ahash { bless {} }
+sub DESTROY { print "destroyed\n" };
+package main;
+*h = ahash X;
+EXPECT
+destroyed
+########
+package X;
+sub aclosure { my $x; bless sub { ++$x } }
+sub DESTROY { print "destroyed\n" };
+package main;
+*c = aclosure X;
+EXPECT
+destroyed
+########
+package X;
+sub any { bless {} }
+my $f = "FH000"; # just to thwart any future optimisations
+sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
+sub DESTROY { print "destroyed\n" }
+package main;
+$x = any X; # to bump sv_objcount. IO objs aren't counted??
+*f = afh X;
+EXPECT
+destroyed
+destroyed
+########