This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Calling cv_undef() on the CV created by newCONSTSUB() would leak like
authorNicholas Clark <nick@ccl4.org>
Wed, 19 Apr 2006 08:42:18 +0000 (08:42 +0000)
committerNicholas Clark <nick@ccl4.org>
Wed, 19 Apr 2006 08:42:18 +0000 (08:42 +0000)
a Jumblie's preferred maritime craft. To free CvFILE for this case,
take advantage of the 0 length prototype that will also be there,
and hang it from the prototype. To do this properly means changing
code to actually pay attention to SvCUR() on prototypes. It turns out
that we always know the length of the prototype string, so this may
be faster. Certainly, it's a memory saving (even ignoring the leak).

p4raw-id: //depot/perl@27896

dump.c
embed.fnc
embed.h
global.sym
mathoms.c
op.c
pod/perlapi.pod
proto.h
sv.c
util.c

diff --git a/dump.c b/dump.c
index 5fa6700..a973a41 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1552,8 +1552,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        }
        break;
     case SVt_PVCV:
-       if (SvPOK(sv))
-           Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n", SvPV_nolen_const(sv));
+       if (SvPOK(sv)) {
+           STRLEN len;
+           const char *const proto =  SvPV_const(sv, len);
+           Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
+                            (int) len, proto);
+       }
        /* FALL THROUGH */
     case SVt_PVFM:
        do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
index b9db13e..82736d7 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -150,7 +150,10 @@ Afnp       |void   |sv_setpvf_mg_nocontext|NN SV* sv|NN const char* pat|...
 Afnp   |int    |fprintf_nocontext|NN PerlIO* stream|NN const char* fmt|...
 Afnp   |int    |printf_nocontext|NN const char* fmt|...
 #endif
-p      |void   |cv_ckproto     |NN const CV* cv|NULLOK const GV* gv|NULLOK const char* p
+bp     |void   |cv_ckproto     |NN const CV* cv|NULLOK const GV* gv\
+                               |NULLOK const char* p
+p      |void   |cv_ckproto_len |NN const CV* cv|NULLOK const GV* gv\
+                               |NULLOK const char* p|const STRLEN len
 pd     |CV*    |cv_clone       |NN CV* proto
 ApdR   |SV*    |gv_const_sv    |NN GV* gv
 ApdR   |SV*    |cv_const_sv    |NULLOK CV* cv
diff --git a/embed.h b/embed.h
index 68d3b2e..430b497 100644 (file)
--- a/embed.h
+++ b/embed.h
 #endif
 #ifdef PERL_CORE
 #define cv_ckproto             Perl_cv_ckproto
+#define cv_ckproto_len         Perl_cv_ckproto_len
 #define cv_clone               Perl_cv_clone
 #endif
 #define gv_const_sv            Perl_gv_const_sv
 #endif
 #ifdef PERL_CORE
 #define cv_ckproto(a,b,c)      Perl_cv_ckproto(aTHX_ a,b,c)
+#define cv_ckproto_len(a,b,c,d)        Perl_cv_ckproto_len(aTHX_ a,b,c,d)
 #define cv_clone(a)            Perl_cv_clone(aTHX_ a)
 #endif
 #define gv_const_sv(a)         Perl_gv_const_sv(aTHX_ a)
index ef432dd..257a2fc 100644 (file)
@@ -74,6 +74,7 @@ Perl_sv_catpvf_mg_nocontext
 Perl_sv_setpvf_mg_nocontext
 Perl_fprintf_nocontext
 Perl_printf_nocontext
+Perl_cv_ckproto
 Perl_gv_const_sv
 Perl_cv_const_sv
 Perl_cv_undef
index 967e035..a2511b9 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -1236,6 +1236,11 @@ Perl_sv_usepvn(pTHX_ SV *sv, char *ptr, STRLEN len)
     sv_usepvn_flags(sv,ptr,len, 0);
 }
 
+void
+Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
+{
+    cv_ckproto_len(cv, gv, p, p ? strlen(p) : 0);
+}
 #endif /* NO_MATHOMS */
 
 /*
diff --git a/op.c b/op.c
index 57e4a1b..86d01d4 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4814,9 +4814,15 @@ Perl_cv_undef(pTHX_ CV *cv)
 }
 
 void
-Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
-{
-    if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+                   const STRLEN len)
+{
+    /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
+       relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
+    if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
+        || (p && (len != SvCUR(cv) /* Not the same length.  */
+                  || memNE(p, SvPVX_const(cv), len))))
+        && ckWARN_d(WARN_PROTOTYPE)) {
        SV* const msg = sv_newmortal();
        SV* name = NULL;
 
@@ -4831,7 +4837,7 @@ Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
            sv_catpvs(msg, ": none");
        sv_catpvs(msg, " vs ");
        if (p)
-           Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+           Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
        else
            sv_catpvs(msg, "none");
        Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
@@ -5036,7 +5042,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            {
                Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
            }
-           cv_ckproto((CV*)gv, NULL, ps);
+           cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
        }
        if (ps)
            sv_setpvn((SV*)gv, ps, ps_len);
@@ -5080,7 +5086,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
          * skipping the prototype check
          */
         if (exists || SvPOK(cv))
-           cv_ckproto(cv, gv, ps);
+           cv_ckproto_len(cv, gv, ps, ps_len);
        /* already defined (or promised)? */
        if (exists || GvASSUMECV(gv)) {
            if ((!block
@@ -5391,6 +5397,15 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
 {
     dVAR;
     CV* cv;
+#ifdef USE_ITHREADS
+    const char *const temp_p = CopFILE(PL_curcop);
+    const STRLEN len = strlen(temp_p);
+#else
+    SV *const temp_sv = CopFILESV(PL_curcop);
+    STRLEN len;
+    const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+    char *const file = temp_p ? savepvn(temp_p, len) : NULL;
 
     ENTER;
 
@@ -5407,10 +5422,18 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
        CopSTASH_set(PL_curcop,stash);
     }
 
-    cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+    /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+       and so doesn't get free()d.  (It's expected to be from the C pre-
+       processor __FILE__ directive). But we need a dynamically allocated one,
+       and we need it to get freed.  So we cheat, and take advantage of the
+       fact that the first 0 bytes of any string always look the same.  */
+    cv = newXS(name, const_sv_xsub, file);
     CvXSUBANY(cv).any_ptr = sv;
     CvCONST_on(cv);
-    sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
+    /* prototype is "".  But this gets free()d.  :-)  */
+    sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL); 
+    /* This gives us a prototype of "", rather than the file name.  */
+    SvCUR_set(cv, 0);
 
 #ifdef USE_ITHREADS
     if (stash)
@@ -7209,6 +7232,7 @@ Perl_ck_subr(pTHX_ OP *o)
     OP *o2 = prev->op_sibling;
     OP *cvop;
     char *proto = NULL;
+    const char *proto_end = NULL;
     CV *cv = NULL;
     GV *namegv = NULL;
     int optional = 0;
@@ -7231,8 +7255,10 @@ Perl_ck_subr(pTHX_ OP *o)
                tmpop->op_private |= OPpEARLY_CV;
            else {
                if (SvPOK(cv)) {
+                   STRLEN len;
                    namegv = CvANON(cv) ? gv : CvGV(cv);
-                   proto = SvPV_nolen((SV*)cv);
+                   proto = SvPV((SV*)cv, len);
+                   proto_end = proto + len;
                }
                if (CvASSERTION(cv)) {
                    if (PL_hints & HINT_ASSERTING) {
@@ -7269,9 +7295,10 @@ Perl_ck_subr(pTHX_ OP *o)
        else
            o3 = o2;
        if (proto) {
-           switch (*proto) {
-           case '\0':
+           if (proto >= proto_end)
                return too_many_arguments(o, gv_ename(namegv));
+
+           switch (*proto) {
            case ';':
                optional = 1;
                proto++;
@@ -7437,8 +7464,8 @@ Perl_ck_subr(pTHX_ OP *o)
        prev = o2;
        o2 = o2->op_sibling;
     } /* while */
-    if (proto && !optional &&
-         (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+    if (proto && !optional && proto_end > proto &&
+       (*proto != '@' && *proto != '%' && *proto != ';'))
        return too_few_arguments(o, gv_ename(namegv));
     if(delete_op) {
 #ifdef PERL_MAD
index ebc1c27..225a5cb 100644 (file)
@@ -2121,8 +2121,8 @@ X<savepvn>
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
        char*   savepvn(const char* pv, I32 len)
 
@@ -5758,7 +5758,7 @@ that pointer (e.g. ptr + 1) be used.
 
 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
 C<len>, and already meets the requirements for storing in C<SvPVX>)
 
        void    sv_usepvn_flags(SV* sv, char* ptr, STRLEN len, U32 flags)
diff --git a/proto.h b/proto.h
index 4808040..760caa1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -304,6 +304,9 @@ PERL_CALLCONV int   Perl_printf_nocontext(const char* fmt, ...)
 PERL_CALLCONV void     Perl_cv_ckproto(pTHX_ const CV* cv, const GV* gv, const char* p)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV void     Perl_cv_ckproto_len(pTHX_ const CV* cv, const GV* gv, const char* p, const STRLEN len)
+                       __attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV CV*      Perl_cv_clone(pTHX_ CV* proto)
                        __attribute__nonnull__(pTHX_1);
 
diff --git a/sv.c b/sv.c
index e9f47dd..df5a556 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3309,8 +3309,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
                        }
                    }
                if (!intro)
-                   cv_ckproto(cv, (GV*)dstr,
-                              SvPOK(sref) ? SvPVX_const(sref) : NULL);
+                   cv_ckproto_len(cv, (GV*)dstr,
+                                  SvPOK(sref) ? SvPVX_const(sref) : NULL,
+                                  SvPOK(sref) ? SvCUR(sref) : 0);
            }
            GvCVGEN(dstr) = 0; /* Switch off cacheness. */
            GvASSUMECV_on(dstr);
@@ -3898,7 +3899,7 @@ that pointer (e.g. ptr + 1) be used.
 
 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
-I<may> be skipped. (i.e. the buffer is actually at least 1 byte longer than
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
 C<len>, and already meets the requirements for storing in C<SvPVX>)
 
 =cut
@@ -3925,20 +3926,21 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags)
 
     allocate = (flags & SV_HAS_TRAILING_NUL)
        ? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
+    if (flags & SV_HAS_TRAILING_NUL) {
+       /* It's long enough - do nothing.
+          Specfically Perl_newCONSTSUB is relying on this.  */
+    } else {
 #ifdef DEBUGGING
-    {
        /* Force a move to shake out bugs in callers.  */
        char *new_ptr = safemalloc(allocate);
        Copy(ptr, new_ptr, len, char);
        PoisonFree(ptr,len,char);
        Safefree(ptr);
        ptr = new_ptr;
-    }
 #else
-    if (!(flags & SV_HAS_TRAILING_NUL)) {
        ptr = saferealloc (ptr, allocate);
-    }
 #endif
+    }
     SvPV_set(sv, ptr);
     SvCUR_set(sv, len);
     SvLEN_set(sv, allocate);
diff --git a/util.c b/util.c
index 18a5cd5..285b8b8 100644 (file)
--- a/util.c
+++ b/util.c
@@ -895,8 +895,8 @@ Perl_savepv(pTHX_ const char *pv)
 
 Perl's version of what C<strndup()> would be if it existed. Returns a
 pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>. The memory allocated for the new string can be
-freed with the C<Safefree()> function.
+C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
 
 =cut
 */