Stop Constant(%s) errors from leaking

This error message uses yyerror, so it doesn’t abort immediately, but
adds it to the queue of error messages.

If there are ten accumulated errors, however, yyerror croaks with a
‘too many errors’ message.

In that circumstance these messages were leaking scalars.

Instead of creating an SV especially to hold the message to pass to
yyerror and then freeing it afterwards, we can instead use Perl_form,
which reuses the same SV every time (PL_mess_sv), eliminating that
leak.  In doing so, we can also combine this with another yyerror/
return in the vicinity, avoiding duplicate code.

The sv passed to S_new_constant was also leaking.  When there is no
error, it is currently mortalised.  When there is an error, it also
needs to be mortalised, in case it is a fatal error.  So this commit
changes it to mortalise it unconditionally.  This means we have to
SvREFCNT_inc the return value on error.

diff --git a/t/op/svleak.t b/t/op/svleak.t
index 75067b1..c0672fc 100644 (file)
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
 
 use Config;
 
-plan tests => 108;
+plan tests => 111;
 
 # 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
@@ -122,6 +122,19 @@ sub STORE  { $_[0]->[$_[1]] = $_[2] }
     leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
 }
 
+# Overloading
+require overload;
+eleak(2, 0, "BEGIN{overload::constant integer=>sub{}} 1,1,1,1,1,1,1,1,1,1",
+     '"too many errors" from constant overloading returning undef');
+# getting this one to leak was complicated; we have to unset LOCALIZE_HH:
+eleak(2, 0, 'BEGIN{overload::constant integer=>sub{}; $^H &= ~ 0x00020000}
+             1,1,1,1,1,1,1,1,1,1',
+     '"too many errors" from constant overloading with $^H sabotaged');
+eleak(2, 0, "BEGIN{overload::constant integer=>sub{}; undef %^H}
+             1,1,1,1,1,1,1,1,1,1",
+     '"too many errors" from constant overloading with %^H undefined');
+
+
 # [perl #74484]  repeated tries leaked SVs on the tmps stack
 
 leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");

diff --git a/toke.c b/toke.c
index 423bebc..8d0ce6a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -9040,12 +9040,13 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
        return &PL_sv_undef;
     }
 
+    sv_2mortal(sv);                    /* Parent created it permanently */
     if (!table
        || ! (PL_hints & HINT_LOCALIZE_HH)
        || ! (cvp = hv_fetch(table, key, keylen, FALSE))
        || ! SvOK(*cvp))
     {
-       SV *msg;
+       char *msg;
        
        /* Here haven't found what we're looking for.  If it is charnames,
         * perhaps it needs to be loaded.  Try doing that before giving up */
@@ -9071,7 +9072,7 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
            }
        }
        if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
-           msg = Perl_newSVpvf(aTHX_
+           msg = Perl_form(aTHX_
                               "Constant(%.*s) unknown",
                                (int)(type ? typelen : len),
                                (type ? type: s));
@@ -9082,25 +9083,21 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
             why3 = "} is not defined";
         report:
             if (*key == 'c') {
-                yyerror_pv(Perl_form(aTHX_
+                msg = Perl_form(aTHX_
                             /* The +3 is for '\N{'; -4 for that, plus '}' */
                             "Unknown charname '%.*s'", (int)typelen - 4, type + 3
-                           ),
-                           UTF ? SVf_UTF8 : 0);
-                return sv;
+                      );
             }
             else {
-                msg = Perl_newSVpvf(aTHX_ "Constant(%.*s): %s%s%s",
+                msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
                                     (int)(type ? typelen : len),
                                     (type ? type: s), why1, why2, why3);
             }
         }
-       yyerror(SvPVX_const(msg));
-       SvREFCNT_dec(msg);
-       return sv;
+       yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
+       return SvREFCNT_inc_simple_NN(sv);
     }
 now_ok:
-    sv_2mortal(sv);                    /* Parent created it permanently */
     cv = *cvp;
     if (!pv && s)
        pv = newSVpvn_flags(s, len, SVs_TEMP);
@@ -9150,6 +9147,7 @@ now_ok:
        why2 = key;
        why3 = "}} did not return a defined value";
        sv = res;
+       (void)sv_2mortal(sv);
        goto report;
     }