Integrate changes #9137,9138,9142 from maintperl into mainline.

fix leak in pregcomp() when RE fails to compile (e.g. m/\\/)

remove squelch controls for "Scalars leaked" messages in most places
(these are now cured)

fix another memory leak reported by purify (tie callbacks that
croak can leak when wiping out magic)

p4raw-link: @9142 on //depot/maint-5.6/perl: 26972843796e21c404c9d13ec5ee86e7b952a2bd
p4raw-link: @9138 on //depot/maint-5.6/perl: ad7f1144250940f9ca43bac32708ec5e718b30ff
p4raw-link: @9137 on //depot/maint-5.6/perl: 1f35595ecca168b4f66e3399344799fdbd496d17

p4raw-id: //depot/perl@9144
p4raw-integrated: from //depot/maint-5.6/perl@9143 'copy in'
	t/pragma/strict-vars (@7318..) t/pragma/warn/regcomp (@7887..)
	t/op/regexp.t (@8551..) t/op/lex_assign.t (@8987..) 'merge in'
	t/op/local.t (@5902..) t/pragma/warn/op (@7846..)
	t/pragma/warnings.t (@7895..) t/comp/proto.t (@8173..)
	t/pragma/warn/toke (@8570..) regcomp.c (@8777..) scope.c
	(@8855..) t/op/pat.t (@9076..)

diff --git a/regcomp.c b/regcomp.c
index 4638d77..19ad253 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -1599,7 +1599,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     else
         RExC_utf8 = 0;
 
-    RExC_precomp = savepvn(exp, xend - exp);
+    RExC_precomp = exp;
     DEBUG_r(if (!PL_colorset) reginitcolors());
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
                      PL_colors[4],PL_colors[5],PL_colors[0],
@@ -1625,7 +1625,6 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
     REGC((U8)REG_MAGIC, (char*)RExC_emit);
 #endif
     if (reg(pRExC_state, 0, &flags) == NULL) {
-       Safefree(RExC_precomp);
        RExC_precomp = Nullch;
        return(NULL);
     }
@@ -1652,7 +1651,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
 #endif
     r->refcnt = 1;
     r->prelen = xend - exp;
-    r->precomp = RExC_precomp;
+    r->precomp = savepvn(RExC_precomp, r->prelen);
     r->subbeg = NULL;
     r->reganch = pm->op_pmflags & PMf_COMPILETIME;
     r->nparens = RExC_npar - 1;        /* set early to validate backrefs */

diff --git a/scope.c b/scope.c
index f0efaf8..106b3dc 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -196,7 +196,7 @@ S_save_scalar_at(pTHX_ SV **sptr)
        if (SvGMAGICAL(osv)) {
            MAGIC* mg;
            bool oldtainted = PL_tainted;
-           mg_get(osv);
+           mg_get(osv);                /* note, can croak! */
            if (PL_tainting && PL_tainted && (mg = mg_find(osv, 't'))) {
                SAVESPTR(mg->mg_obj);
                mg->mg_obj = osv;
@@ -678,13 +678,19 @@ Perl_leave_scope(pTHX_ I32 base)
                SvMAGICAL_off(sv);
                SvMAGIC(sv) = 0;
            }
+           /* XXX this branch is pretty bogus--note that we seem to
+            * only get here if the mg_get() in save_scalar_at() ends
+            * up croaking.  This code irretrievably clears(!) the magic
+            * on the SV to avoid further croaking that might ensue
+            * when the SvSETMAGIC() below is called.  This needs a
+            * total rethink.  --GSAR */
            else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
                     SvTYPE(value) != SVt_PVGV)
            {
                SvFLAGS(value) |= (SvFLAGS(value) &
                                   (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
                SvMAGICAL_off(value);
-               SvMAGIC(value) = 0;
+               mg_free(value);
            }
             SvREFCNT_dec(sv);
            *(SV**)ptr = value;

diff --git a/t/comp/proto.t b/t/comp/proto.t
index 2242857..5fce526 100755 (executable)
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -9,9 +9,6 @@
 # we should test as many as we can.
 #
 
-# XXX known to leak scalars
-$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';

diff --git a/t/op/lex_assign.t b/t/op/lex_assign.t
index ee74d93..d761f73 100755 (executable)
--- a/t/op/lex_assign.t
+++ b/t/op/lex_assign.t
@@ -4,7 +4,6 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 }
-$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; 
 
 umask 0;
 $xref = \ "";

diff --git a/t/op/local.t b/t/op/local.t
index 781afa5..9f977b2 100755 (executable)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -2,9 +2,6 @@
 
 print "1..71\n";
 
-# XXX known to leak scalars
-$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-
 sub foo {
     local($a, $b) = @_;
     local($c, $d);

diff --git a/t/op/pat.t b/t/op/pat.t
index a82da60..293e748 100755 (executable)
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -12,9 +12,6 @@ BEGIN {
 }
 eval 'use Config';          #  Defaults assumed if this fails
 
-# XXX known to leak scalars
-$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-
 $x = "abc\ndef\n";
 
 if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}

diff --git a/t/op/regexp.t b/t/op/regexp.t
index 7fbfc97..4a4d42f 100755 (executable)
--- a/t/op/regexp.t
+++ b/t/op/regexp.t
@@ -1,8 +1,5 @@
 #!./perl
 
-# 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.
 # There are five columns, separated by tabs.

diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars
index 5ba579d..40b5557 100644 (file)
--- a/t/pragma/strict-vars
+++ b/t/pragma/strict-vars
@@ -151,8 +151,6 @@ $d = 1;$i = 1;$n = 1;
 $e = 1;$j = 1;$o = 1;
 $p = 0b12;
 --FILE-- 
-# known scalar leak
-BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; }
 use abc;
 EXPECT
 Global symbol "$f" requires explicit package name at abc.pm line 3.
@@ -171,8 +169,8 @@ Global symbol "$o" requires explicit package name at abc.pm line 7.
 Global symbol "$p" requires explicit package name at abc.pm line 8.
 Illegal binary digit '2' at abc.pm line 8, at end of line
 abc.pm has too many errors.
-Compilation failed in require at - line 3.
-BEGIN failed--compilation aborted at - line 3.
+Compilation failed in require at - line 1.
+BEGIN failed--compilation aborted at - line 1.
 ########
 
 # Check scope of pragma with eval

diff --git a/t/pragma/warn/op b/t/pragma/warn/op
index de326f8..f3c0548 100644 (file)
--- a/t/pragma/warn/op
+++ b/t/pragma/warn/op
@@ -569,7 +569,7 @@ Useless use of a constant in void context at - line 3.
 Useless use of a constant in void context at - line 4.
 ########
 # op.c
-BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak
+#
 use warnings 'misc' ;
 my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 @a =~ /abc/ ;

diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp
index 59076d5..8b86b50 100644 (file)
--- a/t/pragma/warn/regcomp
+++ b/t/pragma/warn/regcomp
@@ -50,7 +50,7 @@ EXPECT
 Unrecognized escape \m passed through before HERE mark in regex m/a\m << HERE / at - line 4.
 ########
 # regcomp.c [S_regpposixcc S_checkposixcc]
-BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
+#
 use warnings 'regexp' ;
 $_ = "" ;
 /[:alpha:]/;
@@ -66,7 +66,7 @@ POSIX syntax [: :] belongs inside character classes before HERE mark in regex m/
 POSIX class [:zog:] unknown before HERE mark in regex m/[[:zog:] << HERE ]/
 ########
 # regcomp.c [S_checkposixcc]
-BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
+#
 use warnings 'regexp' ;
 $_ = "" ;
 /[.zog.]/;
@@ -77,7 +77,7 @@ POSIX syntax [. .] belongs inside character classes before HERE mark in regex m/
 POSIX syntax [. .] is reserved for future extensions before HERE mark in regex m/[.zog.] << HERE /
 ########
 # regcomp.c [S_checkposixcc]
-BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3 }
+#
 use warnings 'regexp' ;
 $_ = "" ;
 /[[.zog.]]/;

diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke
index 2c9433b..4924bb2 100644 (file)
--- a/t/pragma/warn/toke
+++ b/t/pragma/warn/toke
@@ -169,10 +169,6 @@ EXPECT
 Semicolon seems to be missing at - line 3.
 ########
 # toke.c
-BEGIN {
-    # Scalars leaked: due to syntax errors
-    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-}
 use warnings 'syntax' ;
 my $a =+ 2 ;
 $a =- 2 ;
@@ -185,25 +181,21 @@ $a =| 2 ;
 $a =< 2 ;
 $a =/ 2 ;
 EXPECT
-Reversed += operator at - line 7.
-Reversed -= operator at - line 8.
-Reversed *= operator at - line 9.
-Reversed %= operator at - line 10.
-Reversed &= operator at - line 11.
-Reversed .= operator at - line 12.
-Reversed ^= operator at - line 13.
-Reversed |= operator at - line 14.
-Reversed <= operator at - line 15.
-syntax error at - line 12, near "=."
-syntax error at - line 13, near "=^"
-syntax error at - line 14, near "=|"
-Unterminated <> operator at - line 15.
-########
-# toke.c
-BEGIN {
-    # Scalars leaked: due to syntax errors
-    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
-}
+Reversed += operator at - line 3.
+Reversed -= operator at - line 4.
+Reversed *= operator at - line 5.
+Reversed %= operator at - line 6.
+Reversed &= operator at - line 7.
+Reversed .= operator at - line 8.
+Reversed ^= operator at - line 9.
+Reversed |= operator at - line 10.
+Reversed <= operator at - line 11.
+syntax error at - line 8, near "=."
+syntax error at - line 9, near "=^"
+syntax error at - line 10, near "=|"
+Unterminated <> operator at - line 11.
+########
+# toke.c
 no warnings 'syntax' ;
 my $a =+ 2 ;
 $a =- 2 ;
@@ -216,10 +208,10 @@ $a =| 2 ;
 $a =< 2 ;
 $a =/ 2 ;
 EXPECT
-syntax error at - line 12, near "=."
-syntax error at - line 13, near "=^"
-syntax error at - line 14, near "=|"
-Unterminated <> operator at - line 15.
+syntax error at - line 8, near "=."
+syntax error at - line 9, near "=^"
+syntax error at - line 10, near "=|"
+Unterminated <> operator at - line 11.
 ########
 # toke.c
 use warnings 'syntax' ;

diff --git a/t/pragma/warnings.t b/t/pragma/warnings.t
index 872e6e1..e2c7500 100644 (file)
--- a/t/pragma/warnings.t
+++ b/t/pragma/warnings.t
@@ -5,7 +5,6 @@ BEGIN {
     @INC = '../lib';
     $ENV{PERL5LIB} = '../lib';
     require Config; import Config;
-    $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
 }
 
 $| = 1;