Add newXS_len_flags

It accepts a length as well as a pv for the name.

Since newXS_flags is marked with M in embed.fnc and is undocumented,
technically policy allows me to change it, but there are files
throughout cpan/ that use newXS_flags.  So it seemed safer to add a
new function.

diff --git a/embed.fnc b/embed.fnc
index 37c15ce..16cc090 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -874,6 +874,10 @@ Apda       |OP*    |newSLICEOP     |I32 flags|NULLOK OP* subscript|NULLOK OP* listop
 Apda   |OP*    |newSTATEOP     |I32 flags|NULLOK char* label|NULLOK OP* o
 Abm    |CV*    |newSUB         |I32 floor|NULLOK OP* o|NULLOK OP* proto \
                                |NULLOK OP* block
+p      |CV *   |newXS_len_flags|NULLOK const char *name|STRLEN len \
+                               |NN XSUBADDR_t subaddr\
+                               |NN const char *const filename \
+                               |NULLOK const char *const proto|U32 flags
 ApM    |CV *   |newXS_flags    |NULLOK const char *name|NN XSUBADDR_t subaddr\
                                |NN const char *const filename \
                                |NULLOK const char *const proto|U32 flags

diff --git a/embed.h b/embed.h
index e27dd51..e591762 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1137,6 +1137,7 @@
 #define my_stat_flags(a)       Perl_my_stat_flags(aTHX_ a)
 #define my_swabn               Perl_my_swabn
 #define my_unexec()            Perl_my_unexec(aTHX)
+#define newXS_len_flags(a,b,c,d,e,f)   Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f)
 #define nextargv(a)            Perl_nextargv(aTHX_ a)
 #define oopsAV(a)              Perl_oopsAV(aTHX_ a)
 #define oopsHV(a)              Perl_oopsHV(aTHX_ a)

diff --git a/op.c b/op.c
index d4d4a05..e4a9f13 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6971,12 +6971,27 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
                 const char *const filename, const char *const proto,
                 U32 flags)
 {
+    PERL_ARGS_ASSERT_NEWXS_FLAGS;
+    return newXS_len_flags(
+       name, name ? strlen(name) : 0, subaddr, filename, proto, flags
+    );
+}
+
+CV *
+Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
+                          XSUBADDR_t subaddr, const char *const filename,
+                          const char *const proto, U32 flags)
+{
     CV *cv;
 
-    PERL_ARGS_ASSERT_NEWXS_FLAGS;
+    PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
 
     {
-        GV * const gv = gv_fetchpv(name ? name :
+        GV * const gv = name
+                        ? gv_fetchpvn(
+                               name,len,GV_ADDMULTI|flags,SVt_PVCV
+                          )
+                        : gv_fetchpv(
                             (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
                             GV_ADDMULTI | flags, SVt_PVCV);
     

diff --git a/proto.h b/proto.h
index b891da3..8bec0b2 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2781,6 +2781,12 @@ PERL_CALLCONV CV *       Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
 #define PERL_ARGS_ASSERT_NEWXS_FLAGS   \
        assert(subaddr); assert(filename)
 
+PERL_CALLCONV CV *     Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
+                       __attribute__nonnull__(pTHX_3)
+                       __attribute__nonnull__(pTHX_4);
+#define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS       \
+       assert(subaddr); assert(filename)
+
 PERL_CALLCONV void     Perl_new_collate(pTHX_ const char* newcoll);
 PERL_CALLCONV void     Perl_new_ctype(pTHX_ const char* newctype)
                        __attribute__nonnull__(pTHX_1);