Perl 5.005b1t2/perl5.004_63 (resend)

p4raw-id: //depot/perl@869

diff --git a/sv.c b/sv.c
index 30a4ccf..1abc3fd 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -335,8 +335,19 @@ do_clean_objs(SV *sv)
 static void
 do_clean_named_objs(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
 

diff --git a/t/op/misc.t b/t/op/misc.t
index 40c9c38..582ffa7 100755 (executable)
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -368,3 +368,47 @@ EXPECT
 1
 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
+########