Fix bug in DynaLoader, which has been passing a filename in dynamic

storage to newXS() seemingly forever. This involves creating
newXS_flags(), with the first flag being "arrange to copy the
filename and free it at the right time".

p4raw-id: //depot/perl@28063

diff --git a/XSUB.h b/XSUB.h
index f6b4f9d..580d639 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -273,7 +273,7 @@ Rethrows a previously caught exception.  See L<perlguts/"Exception Handling">.
 #define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END
 #define XSRETURN_EMPTY STMT_START {                XSRETURN(0); } STMT_END
 
-#define newXSproto(a,b,c,d)    sv_setpv((SV*)newXS(a,b,c), d)
+#define newXSproto(a,b,c,d)    newXS_flags(a,b,c,d,0)
 
 #ifdef XS_VERSION
 #  define XS_VERSION_BOOTCHECK \

diff --git a/cv.h b/cv.h
index 219686b..65a3457 100644 (file)
--- a/cv.h
+++ b/cv.h
@@ -202,6 +202,9 @@ Returns the stash of the CV.
 #define CvISXSUB_on(cv)                (CvFLAGS(cv) |= CVf_ISXSUB)
 #define CvISXSUB_off(cv)       (CvFLAGS(cv) &= ~CVf_ISXSUB)
 
+/* Flags for newXS_flags  */
+#define XS_DYNAMIC_FILENAME    0x01    /* The filename isn't static  */
+
 /*
 =head1 CV reference counts and CvOUTSIDE
 

diff --git a/embed.fnc b/embed.fnc
index 9e32b5e..4d5bf75 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -541,6 +541,9 @@ Apa |OP*    |newRANGE       |I32 flags|NN OP* left|NN OP* right
 Apa    |OP*    |newSLICEOP     |I32 flags|NULLOK OP* subscript|NULLOK OP* listop
 Apa    |OP*    |newSTATEOP     |I32 flags|NULLOK char* label|NULLOK OP* o
 Ap     |CV*    |newSUB         |I32 floor|NULLOK OP* o|NULLOK OP* proto|NULLOK OP* block
+ApM    |CV *   |newXS_flags    |NULLOK const char *name|NN XSUBADDR_t subaddr\
+                               |NN const char *const filename \
+                               |NULLOK const char *const proto|U32 flags
 Apd    |CV*    |newXS          |NULLOK const char* name|NN XSUBADDR_t f|NN const char* filename
 Apda   |AV*    |newAV
 Apa    |OP*    |newAVREF       |NN OP* o

diff --git a/embed.h b/embed.h
index 7000eb0..5f0c6b2 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -542,6 +542,7 @@
 #define newSLICEOP             Perl_newSLICEOP
 #define newSTATEOP             Perl_newSTATEOP
 #define newSUB                 Perl_newSUB
+#define newXS_flags            Perl_newXS_flags
 #define newXS                  Perl_newXS
 #define newAV                  Perl_newAV
 #define newAVREF               Perl_newAVREF
@@ -2709,6 +2710,7 @@
 #define newSLICEOP(a,b,c)      Perl_newSLICEOP(aTHX_ a,b,c)
 #define newSTATEOP(a,b,c)      Perl_newSTATEOP(aTHX_ a,b,c)
 #define newSUB(a,b,c,d)                Perl_newSUB(aTHX_ a,b,c,d)
+#define newXS_flags(a,b,c,d,e) Perl_newXS_flags(aTHX_ a,b,c,d,e)
 #define newXS(a,b,c)           Perl_newXS(aTHX_ a,b,c)
 #define newAV()                        Perl_newAV(aTHX)
 #define newAVREF(a)            Perl_newAVREF(aTHX_ a)

diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs
index ea6de7b..8529097 100644 (file)
--- a/ext/DynaLoader/dl_aix.xs
+++ b/ext/DynaLoader/dl_aix.xs
@@ -748,9 +748,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
        perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_beos.xs b/ext/DynaLoader/dl_beos.xs
index d81030c..ae40269 100644 (file)
--- a/ext/DynaLoader/dl_beos.xs
+++ b/ext/DynaLoader/dl_beos.xs
@@ -102,9 +102,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
                perl_name, (unsigned long) symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs
index 101efac..127c0d1 100644 (file)
--- a/ext/DynaLoader/dl_dld.xs
+++ b/ext/DynaLoader/dl_dld.xs
@@ -173,10 +173,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
            perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
-
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 char *
 dl_error()

diff --git a/ext/DynaLoader/dl_dllload.xs b/ext/DynaLoader/dl_dllload.xs
index 497e096..c5ce35a 100644 (file)
--- a/ext/DynaLoader/dl_dllload.xs
+++ b/ext/DynaLoader/dl_dllload.xs
@@ -174,9 +174,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
                perl_name, (unsigned long) symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs
index 5978bfd..83f5aed 100644 (file)
--- a/ext/DynaLoader/dl_dlopen.xs
+++ b/ext/DynaLoader/dl_dlopen.xs
@@ -250,9 +250,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%"UVxf")\n",
                perl_name, PTR2UV(symref)));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       DPTR2FPTR(XSUBADDR_t, symref),
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             DPTR2FPTR(XSUBADDR_t, symref),
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_dyld.xs b/ext/DynaLoader/dl_dyld.xs
index ef96b48..eac0408 100644 (file)
--- a/ext/DynaLoader/dl_dyld.xs
+++ b/ext/DynaLoader/dl_dyld.xs
@@ -205,9 +205,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
            perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs
index 5e7c744..0c751dd 100644 (file)
--- a/ext/DynaLoader/dl_hpux.xs
+++ b/ext/DynaLoader/dl_hpux.xs
@@ -164,10 +164,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
            perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
-
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 char *
 dl_error()

diff --git a/ext/DynaLoader/dl_mac.xs b/ext/DynaLoader/dl_mac.xs
index 6c624e7..826caf2 100644 (file)
--- a/ext/DynaLoader/dl_mac.xs
+++ b/ext/DynaLoader/dl_mac.xs
@@ -130,7 +130,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
                perl_name, symref));
-    ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_mpeix.xs b/ext/DynaLoader/dl_mpeix.xs
index 55a5c3f..4b339c5 100644 (file)
--- a/ext/DynaLoader/dl_mpeix.xs
+++ b/ext/DynaLoader/dl_mpeix.xs
@@ -115,9 +115,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
             perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 char *
 dl_error()

diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs
index 265800b..e61c800 100644 (file)
--- a/ext/DynaLoader/dl_next.xs
+++ b/ext/DynaLoader/dl_next.xs
@@ -305,9 +305,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
            perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_symbian.xs b/ext/DynaLoader/dl_symbian.xs
index 6cf1d1f..b2f2732 100644 (file)
--- a/ext/DynaLoader/dl_symbian.xs
+++ b/ext/DynaLoader/dl_symbian.xs
@@ -207,9 +207,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     void *             symref 
     char *             filename
     CODE:
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/ext/DynaLoader/dl_vmesa.xs b/ext/DynaLoader/dl_vmesa.xs
index a28d424..8b0d756 100644 (file)
--- a/ext/DynaLoader/dl_vmesa.xs
+++ b/ext/DynaLoader/dl_vmesa.xs
@@ -160,9 +160,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
                perl_name, (unsigned long) symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                       (void(*)(pTHX_ CV *))symref,
-                                       filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
  
  
 char *

diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs
index 4d2a93a..1df7a40 100644 (file)
--- a/ext/DynaLoader/dl_vms.xs
+++ b/ext/DynaLoader/dl_vms.xs
@@ -368,9 +368,10 @@ dl_install_xsub(perl_name, symref, filename="$Package")
     CODE:
     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n",
         perl_name, symref));
-    ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name,
-                                     (void(*)(pTHX_ CV *))symref,
-                                     filename)));
+    ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
+                                             (void(*)(pTHX_ CV *))symref,
+                                             filename, NULL,
+                                             XS_DYNAMIC_FILENAME)));
 
 
 char *

diff --git a/op.c b/op.c
index 1e85254..366897b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5429,15 +5429,10 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
     /* 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);
+       and we need it to get freed.  */
+    cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
     CvXSUBANY(cv).any_ptr = sv;
     CvCONST_on(cv);
-    /* 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)
@@ -5448,10 +5443,55 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
     return cv;
 }
 
+CV *
+Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
+                const char *const filename, const char *const proto,
+                U32 flags)
+{
+    CV *cv = newXS(name, subaddr, filename);
+
+    if (flags & XS_DYNAMIC_FILENAME) {
+       /* We need to "make arrangements" (ie cheat) to ensure that the
+          filename lasts as long as the PVCV we just created, but also doesn't
+          leak  */
+       STRLEN filename_len = strlen(filename);
+       STRLEN proto_and_file_len = filename_len;
+       char *proto_and_file;
+       STRLEN proto_len;
+
+       if (proto) {
+           proto_len = strlen(proto);
+           proto_and_file_len += proto_len;
+
+           Newx(proto_and_file, proto_and_file_len + 1, char);
+           Copy(proto, proto_and_file, proto_len, char);
+           Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
+       } else {
+           proto_len = 0;
+           proto_and_file = savepvn(filename, filename_len);
+       }
+
+       /* This gets free()d.  :-)  */
+       sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+                       SV_HAS_TRAILING_NUL);
+       if (proto) {
+           /* This gives us the correct prototype, rather than one with the
+              file name appended.  */
+           SvCUR_set(cv, proto_len);
+       } else {
+           SvPOK_off(cv);
+       }
+    } else {
+       sv_setpv((SV *)cv, proto);
+    }
+    return cv;
+}
+
 /*
 =for apidoc U||newXS
 
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
 
 =cut
 */

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 9cbf854..d608eef 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2725,7 +2725,8 @@ Found in file op.c
 =item newXS
 X<newXS>
 
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
 
 =for hackers
 Found in file op.c

diff --git a/proto.h b/proto.h
index ed3faea..dcffdaf 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1481,6 +1481,10 @@ PERL_CALLCONV OP*        Perl_newSTATEOP(pTHX_ I32 flags, char* label, OP* o)
                        __attribute__warn_unused_result__;
 
 PERL_CALLCONV CV*      Perl_newSUB(pTHX_ I32 floor, OP* o, OP* proto, OP* block);
+PERL_CALLCONV CV *     Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
+
 PERL_CALLCONV CV*      Perl_newXS(pTHX_ const char* name, XSUBADDR_t f, const char* filename)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3);