fix small memory leak when mess_sv happens to be touched by magic

p4raw-id: //depot/perl@1585

diff --git a/perl.c b/perl.c
index bebcb02..df306dc 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -567,6 +567,17 @@ perl_destruct(register PerlInterpreter *sv_interp)
     /* As the absolutely last thing, free the non-arena SV for mess() */
 
     if (PL_mess_sv) {
+       /* it could have accumulated taint magic */
+       if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
+           MAGIC* mg;
+           MAGIC* moremagic;
+           for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
+               moremagic = mg->mg_moremagic;
+               if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
+                   Safefree(mg->mg_ptr);
+               Safefree(mg);
+           }
+       }
        /* we know that type >= SVt_PV */
        SvOOK_off(PL_mess_sv);
        Safefree(SvPVX(PL_mess_sv));

diff --git a/t/lib/thread.t b/t/lib/thread.t
index fecfb03..83407a9 100755 (executable)
--- a/t/lib/thread.t
+++ b/t/lib/thread.t
@@ -8,7 +8,9 @@ BEGIN {
        print "1..0\n";
        exit 0;
     }
-    $ENV{PERL_DESTRUCT_LEVEL} = 0;     # XXX known trouble with global destruction
+
+    # XXX known trouble with global destruction
+    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 }
 $| = 1;
 print "1..14\n";

diff --git a/t/op/local.t b/t/op/local.t
index f8c037d..2f674d1 100755 (executable)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -4,7 +4,8 @@
 
 print "1..58\n";
 
-$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 sub foo {
     local($a, $b) = @_;

diff --git a/t/op/pat.t b/t/op/pat.t
index ef014f2..f16783e 100755 (executable)
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -12,7 +12,8 @@ BEGIN {
 }
 eval 'use Config';          #  Defaults assumed if this fails
 
-$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 $x = "abc\ndef\n";
 

diff --git a/t/op/regexp.t b/t/op/regexp.t
index 4ebb8c0..0ec069b 100755 (executable)
--- a/t/op/regexp.t
+++ b/t/op/regexp.t
@@ -1,6 +1,7 @@
 #!./perl
 
-$ENV{PERL_DESTRUCT_LEVEL} = 0; # XXX known to leaks scalars
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 
 # The tests are in a separate file 't/op/re_tests'.
 # Each line in that file is a separate test.