leakfinder.pl: More exceptions

diff --git a/Makefile.SH b/Makefile.SH
index 7a8399b..97057fd 100755 (executable)
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -1,5 +1,14 @@
 #!/bin/sh
 
+# quote() - Creates a shell literal
+# Usage:  echo "...$( quote "..." )..."
+quote() {
+       case "$1" in
+       '') echo "''" ;;
+       *)  echo "$1" | sed 's/\([^a-zA-Z0-9.:_\-\/]\)/\\\1/g' ;;
+       esac
+}
+
 case $PERL_CONFIG_SH in
 '')
        if test -f config.sh
@@ -39,10 +48,8 @@ true)
        # Prefix all runs of 'miniperl' and 'perl' with
        # $ldlibpth so that ./perl finds *this* shared libperl.
        case "$LD_LIBRARY_PATH" in
-       '')
-               ldlibpth="LD_LIBRARY_PATH=`pwd`";;
-       *)
-               ldlibpth="LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}";;
+       '')  ldlibpth="LD_LIBRARY_PATH=$( quote "`pwd`" )" ;;
+       *)   ldlibpth="LD_LIBRARY_PATH=$( quote "`pwd`" ):$( quote "$LD_LIBRARY_PATH" )" ;;
        esac
 
        pldlflags="$cccdlflags"
@@ -121,19 +128,19 @@ true)
                ldlibpth=''
                ;;
            *)
-               eval "ldlibpth=\"$ldlibpthname=`pwd`:\$$ldlibpthname\""
+               eval "ldlibpthval=\"\$$ldlibpthname\""
+
+               case "$ldlibpthval" in
+               '')  ldlibpth="$ldlibpthname=$( quote "`pwd`" )" ;;
+               *)   ldlibpth="$ldlibpthname=$( quote "`pwd`" ):$( quote "$ldlibpthval" )" ;;
+               esac
+
                ;;
            esac
-           # Strip off any trailing :'s
-           ldlibpth=`echo $ldlibpth | sed 's/:*$//'`
+
            ;;
         esac
 
-       case "$ldlibpth" in
-       # Protect any spaces
-       *" "*) ldlibpth=`echo $ldlibpth|sed 's/ /\\\\ /g'` ;;
-       esac
-
        case "$osname" in
        linux)
            # If there is a pre-existing $libperl from a previous

diff --git a/Porting/leakfinder.pl b/Porting/leakfinder.pl
index babec7c..a69a4b8 100644 (file)
--- a/Porting/leakfinder.pl
+++ b/Porting/leakfinder.pl
@@ -33,7 +33,7 @@ for(`find .`) {
             open STDIN, "</dev/null";
             open STDERR, ">/dev/null";
             \$unused_variable = '$q';
-            eval \$unused_variable;
+            eval \$unused_variable for my \$also_unused(1..3);
             print oUt sv_count, "\n";
             eval \$unused_variable;
             print oUt sv_count, "\n";
@@ -60,6 +60,7 @@ binmode *STDERR, ":encoding(utf8)";
 binmode *STDOUT, ":encoding(utf8)";
 $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
 CHECK { $main::phase++ }
+$config{$k} = [ $config{$k} ]
 const char* file = __FILE__;
 $data = [ $data ];
 do { $tainted_value = shift @ENV_values  } while(!$tainted_value || ref $tainted_value);
@@ -70,6 +71,7 @@ $formdata->{$key} = [ $formdata->{$key}, $value ];
 $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
 { $h[++$i] = $_ }
 $i = int($i/2) until defined $self->[$i/2];
+$invmap_ref->[$i] = [ $invmap_ref->[$i] ];
 $i++ while $self->{ids}{"$t$i"}++;
 $mod_hash->{$k} = [ $mod_hash->{$k} ];
 $modlibname =~ s,[\5c\5c/][^\5c\5c/]+$,, while $c--;    # Q&D basename
@@ -98,8 +100,10 @@ $resp = [$resp]
 $self->{DIR} = [grep $_, split ":", $self->{DIR}];
 $share_dir->{dist} = [ $share_dir->{dist} ];
 sleep;
+sleep(300);
 sleep($waitfor - 2);    # Workaround for perlbug #49073
 $spec = [$spec, $_[0]];
+$stack[$i++] &= ~1;
 $step = [$step];
 Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
 weaken($objs[@objs] = $h{$_} = []);

diff --git a/op.c b/op.c
index 8fab398..b2801c7 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4650,7 +4650,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
 
                /* attach the anon CV to the pad so that
                 * pad_fixup_inner_anons() can find it */
-               (void)pad_add_anon(cv, o->op_type);
+               if (cv) (void)pad_add_anon(cv, o->op_type);
                SvREFCNT_inc_simple_void(cv);
            }
            else {
@@ -7370,15 +7370,14 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 
     if (ec) {
        op_free(block);
-       cv = PL_compcv;
+       SvREFCNT_dec(PL_compcv);
+       PL_compcv = 0;
        if (name && block) {
            const char *s = strrchr(name, ':');
            s = s ? s+1 : name;
            if (strEQ(s, "BEGIN")) {
                const char not_safe[] =
                    "BEGIN not safe after errors--compilation aborted";
-               PL_compcv = 0;
-               SvREFCNT_dec(cv);
                if (PL_in_eval & EVAL_KEEPERR)
                    Perl_croak(aTHX_ not_safe);
                else {
@@ -7624,7 +7623,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
        HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+       if (!name) SAVEFREESV(cv);
        apply_attrs(stash, MUTABLE_SV(cv), attrs);
+       if (!name) SvREFCNT_inc_simple_void_NN(cv);
     }
 
     if (block && has_name) {
@@ -8174,6 +8175,9 @@ Perl_ck_anoncode(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_CK_ANONCODE;
 
+    /* After errors, we won’t have any sub. */
+    if (!cSVOPo->op_sv) return o;
+
     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
     if (!PL_madskills)
        cSVOPo->op_sv = NULL;

diff --git a/pp_ctl.c b/pp_ctl.c
index 22e1cea..1f4afc0 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2799,13 +2799,17 @@ PP(pp_goto)
            FREETMPS;
            cxix = dopoptosub(cxstack_ix);
            if (cxix < 0)
+           {
+               SvREFCNT_dec(cv);
                DIE(aTHX_ "Can't goto subroutine outside a subroutine");
+           }
            if (cxix < cxstack_ix)
                dounwind(cxix);
            TOPBLOCK(cx);
            SPAGAIN;
            /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
            if (CxTYPE(cx) == CXt_EVAL) {
+               SvREFCNT_dec(cv);
                if (CxREALEVAL(cx))
                /* diag_listed_as: Can't goto subroutine from an eval-%s */
                    DIE(aTHX_ "Can't goto subroutine from an eval-string");
@@ -2814,7 +2818,10 @@ PP(pp_goto)
                    DIE(aTHX_ "Can't goto subroutine from an eval-block");
            }
            else if (CxMULTICALL(cx))
+           {
+               SvREFCNT_dec(cv);
                DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
+           }
            if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
                AV* av = cx->blk_sub.argarray;
 
@@ -2889,11 +2896,6 @@ PP(pp_goto)
            }
            else {
                PADLIST * const padlist = CvPADLIST(cv);
-               if (CxTYPE(cx) == CXt_EVAL) {
-                   PL_in_eval = CxOLD_IN_EVAL(cx);
-                   PL_eval_root = cx->blk_eval.old_eval_root;
-                   cx->cx_type = CXt_SUB;
-               }
                cx->blk_sub.cv = cv;
                cx->blk_sub.olddepth = CvDEPTH(cv);
 

diff --git a/t/op/svleak.t b/t/op/svleak.t
index ceaf480..8416656 100644 (file)
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
 
 use Config;
 
-plan tests => 60;
+plan tests => 65;
 
 # run some code N times. If the number of SVs at the end of loop N is
 # greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -72,6 +72,10 @@ leak(5, 1, sub {push @a,1;},       "basic check 3 of leak test infrastructure");
 
 eleak(2, 0, 'sub{<*>}');
 
+eleak(2, 0, 'goto sub {}', 'goto &sub in eval');
+eleak(2, 0, '() = sort { goto sub {} } 1,2', 'goto &sub in sort');
+eleak(2, 0, '/(?{ goto sub {} })/', 'goto &sub in regexp');
+
 sub TIEARRAY   { bless [], $_[0] }
 sub FETCH      { $_[0]->[$_[1]] }
 sub STORE      { $_[0]->[$_[1]] = $_[2] }
@@ -190,6 +194,9 @@ SKIP: {
     leak(2, 0, sub { eval q{ my $x = "x"; "abc" =~ /$x/ for 1..5 } }, '#114356');
 }
 
+eleak(2, 0, '+sub:a{}', 'anon subs with invalid attributes');
+eleak(2, 0, 'no warnings; sub a{1 1}', 'sub with syntax error');
+
 # Syntax errors
 eleak(2, 0, '"${<<END}"
                  ', 'unterminated here-doc in quotes in multiline eval');