From: Nicholas Clark Date: Tue, 2 May 2006 15:55:25 +0000 (+0000) Subject: Fix bug in DynaLoader, which has been passing a filename in dynamic X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=77004dee2553ce034a8a58b2b2849e3656df46c3;p=p5sagit%2Fp5-mst-13.2.git 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 --- a/XSUB.h +++ b/XSUB.h @@ -273,7 +273,7 @@ Rethrows a previously caught exception. See L. #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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 to hook up XSUBs as Perl subs. +Used by C to hook up XSUBs as Perl subs. I 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 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -2725,7 +2725,8 @@ Found in file op.c =item newXS X -Used by C to hook up XSUBs as Perl subs. +Used by C to hook up XSUBs as Perl subs. I 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 --- 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);