summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--XSUB.h2
-rw-r--r--cv.h3
-rw-r--r--embed.fnc3
-rw-r--r--embed.h2
-rw-r--r--ext/DynaLoader/dl_aix.xs7
-rw-r--r--ext/DynaLoader/dl_beos.xs7
-rw-r--r--ext/DynaLoader/dl_dld.xs8
-rw-r--r--ext/DynaLoader/dl_dllload.xs7
-rw-r--r--ext/DynaLoader/dl_dlopen.xs7
-rw-r--r--ext/DynaLoader/dl_dyld.xs7
-rw-r--r--ext/DynaLoader/dl_hpux.xs8
-rw-r--r--ext/DynaLoader/dl_mac.xs5
-rw-r--r--ext/DynaLoader/dl_mpeix.xs7
-rw-r--r--ext/DynaLoader/dl_next.xs7
-rw-r--r--ext/DynaLoader/dl_symbian.xs7
-rw-r--r--ext/DynaLoader/dl_vmesa.xs7
-rw-r--r--ext/DynaLoader/dl_vms.xs7
-rw-r--r--op.c56
-rw-r--r--pod/perlapi.pod3
-rw-r--r--proto.h4
20 files changed, 115 insertions, 49 deletions
diff --git a/XSUB.h b/XSUB.h
index f6b4f9d7a5..580d639c07 100644
--- 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 219686bada..65a34571f9 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 9e32b5e197..4d5bf75f4d 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 7000eb0d12..5f0c6b25ab 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 ea6de7b198..8529097469 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 d81030c91d..ae40269338 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 101efac0cc..127c0d1455 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 497e09651f..c5ce35a224 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 5978bfd037..83f5aed074 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 ef96b48ffd..eac0408d5f 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 5e7c7445af..0c751dd2b7 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 6c624e789b..826caf204d 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 55a5c3f30b..4b339c5bb9 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 265800b2af..e61c800802 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 6cf1d1f658..b2f27321e6 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 a28d4246eb..8b0d756349 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 4d2a93aca6..1df7a40a13 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 1e852546ba..366897b7b0 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<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 9cbf85472e..d608eef3c3 100644
--- 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 ed3faeafd6..dcffdaf800 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);
View Lorry Controller Status