embed.fnc: Add flag for bypass macro existence

Sometimes a function is reduced to be a wrapper, and we want for code to
directly call the underlying one, but we retain the old 'Perl_foo'
function to avoid breaking code that used that form.  I've tried various
kludges around that, but this seems more promising.

diff --git a/autodoc.pl b/autodoc.pl
index 0b4ec20..26b4284 100644 (file)
--- a/autodoc.pl
+++ b/autodoc.pl
@@ -132,6 +132,8 @@ DOC:
                $embed_may_change = $embed_docref->{flags} =~ /x/;
                 $flags .= 'D' if $embed_docref->{flags} =~ /D/;
                 $flags .= 'O' if $embed_docref->{flags} =~ /O/;
+                $flags .= 'p' if $embed_docref->{flags} =~ /p/;
+                $flags .= 'M' if $embed_docref->{flags} =~ /M/;
            } else {
                $missing{$name} = $file;
            }
@@ -203,10 +205,17 @@ existing code.\n\n$docs";
         $docs = "\n\nNOTE: this function is experimental and may change or be
 removed without notice.\n\n$docs" if $flags =~ /x/;
     }
+
+    # Is Perl_, but no #define foo # Perl_foo
+    my $p = $flags =~ /p/ && $flags =~ /o/ && $flags !~ /M/;
+
     $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n"
        if $flags =~ /O/;
-    $docs .= "NOTE: this function must be explicitly called as Perl_$name with an aTHX_ parameter.\n\n"
-        if $flags =~ /o/;
+    if ($p) {
+        $docs .= "NOTE: this function must be explicitly called as Perl_$name";
+        $docs .= " with an aTHX_ parameter";
+        $docs .= ".\n\n"
+    }
 
     print $fh "=item $name\nX<$name>\n$docs";
 
@@ -218,7 +227,6 @@ removed without notice.\n\n$docs" if $flags =~ /x/;
         } elsif ($flags =~ /n/) { # no args
             print $fh "\t$ret\t$name";
         } else { # full usage
-            my $p            = $flags =~ /o/; # no #define foo Perl_foo
             my $n            = "Perl_"x$p . $name;
             my $large_ret    = length $ret > 7;
             my $indent_size  = 7+8 # nroff: 7 under =head + 8 under =item

diff --git a/embed.fnc b/embed.fnc
index cc088b5..46a570c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -102,7 +102,13 @@
 :                PERL_STATIC_INLINE is added to declaration;
 :         embed.h: "#define foo S_foo" or Perl_foo entries added
 :
+:   M  There is an extra macro that bypasses this function
 :
+:      (requires 'p', and implies 'o')  The function exists so that callers who
+:      used the 'Perl_' form can continue to do so, but there is a macro
+:      available with out the 'Perl_' prefix that bypasses the function call,
+:      such as when the function has been reduced to a wrapper around another
+:      one.
 :
 :   m  Implemented as a macro:
 :
@@ -671,7 +677,7 @@ Ap  |void*  |hv_common      |NULLOK HV *hv|NULLOK SV *keysv \
 Ap     |void*  |hv_common_key_len|NULLOK HV *hv|NN const char *key \
                                |I32 klen_i32|const int action|NULLOK SV *val \
                                |const U32 hash
-Apod   |STRLEN |hv_fill        |NN HV *const hv
+AMpod  |STRLEN |hv_fill        |NN HV *const hv
 Ap     |void   |hv_free_ent    |NN HV *hv|NULLOK HE *entry
 Apd    |I32    |hv_iterinit    |NN HV *hv
 ApdR   |char*  |hv_iterkey     |NN HE* entry|NN I32* retlen
@@ -1256,13 +1262,8 @@ Apd      |SV*    |vstringify     |NN SV *vs
 Apd    |int    |vcmp           |NN SV *lhv|NN SV *rhv
 : Used in pp_hot.c and pp_sys.c
 p      |PerlIO*|nextargv       |NN GV* gv|bool nomagicopen
-#ifdef HAS_MEMMEM
-AdTopP |char*  |ninstr         |NN const char* big|NN const char* bigend \
+AdMTpP |char*  |ninstr         |NN const char* big|NN const char* bigend \
                                |NN const char* little|NN const char* lend
-#else
-AdTpP  |char*  |ninstr         |NN const char* big|NN const char* bigend \
-                               |NN const char* little|NN const char* lend
-#endif
 Apd    |void   |op_free        |NULLOK OP* arg
 xp     |OP*    |op_unscope     |NULLOK OP* o
 #ifdef PERL_CORE
@@ -1581,10 +1582,10 @@ Apd     |void   |sv_clear       |NN SV *const orig_sv
 #if defined(PERL_IN_SV_C)
 S      |bool   |curse          |NN SV * const sv|const bool check_refcnt
 #endif
-Aopd   |I32    |sv_cmp         |NULLOK SV *const sv1|NULLOK SV *const sv2
+AMopd  |I32    |sv_cmp         |NULLOK SV *const sv1|NULLOK SV *const sv2
 Apd    |I32    |sv_cmp_flags   |NULLOK SV *const sv1|NULLOK SV *const sv2 \
                                |const U32 flags
-Aopd   |I32    |sv_cmp_locale  |NULLOK SV *const sv1|NULLOK SV *const sv2
+AMopd  |I32    |sv_cmp_locale  |NULLOK SV *const sv1|NULLOK SV *const sv2
 Apd    |I32    |sv_cmp_locale_flags    |NULLOK SV *const sv1 \
                                |NULLOK SV *const sv2|const U32 flags
 #if defined(USE_LOCALE_COLLATE)
@@ -1859,7 +1860,7 @@ AipdRT    |U8*    |utf8_hop_safe  |NN const U8 *s|SSize_t off|NN const U8 *start|NN con
 Apxd   |U8*    |utf8_to_bytes  |NN U8 *s|NN STRLEN *lenp
 Apd    |int    |bytes_cmp_utf8 |NN const U8 *b|STRLEN blen|NN const U8 *u \
                                |STRLEN ulen
-Axodp  |U8*    |bytes_from_utf8|NN const U8 *s|NN STRLEN *lenp|NN bool *is_utf8p
+AMxdp  |U8*    |bytes_from_utf8|NN const U8 *s|NN STRLEN *lenp|NN bool *is_utf8p
 AxTp   |U8*    |bytes_from_utf8_loc|NN const U8 *s                         \
                                    |NN STRLEN *lenp                        \
                                    |NN bool *is_utf8p                      \
@@ -1868,15 +1869,15 @@ Apxd    |U8*    |bytes_to_utf8  |NN const U8 *s|NN STRLEN *lenp
 ApdD   |UV     |utf8_to_uvchr  |NN const U8 *s|NULLOK STRLEN *retlen
 AbpdD  |UV     |utf8_to_uvuni  |NN const U8 *s|NULLOK STRLEN *retlen
 AbpxD  |UV     |valid_utf8_to_uvuni    |NN const U8 *s|NULLOK STRLEN *retlen
-Aopd   |UV     |utf8_to_uvchr_buf      |NN const U8 *s|NN const U8 *send|NULLOK STRLEN *retlen
+AMpd   |UV     |utf8_to_uvchr_buf      |NN const U8 *s|NN const U8 *send|NULLOK STRLEN *retlen
 ApdD   |UV     |utf8_to_uvuni_buf      |NN const U8 *s|NN const U8 *send|NULLOK STRLEN *retlen
 px     |bool   |check_utf8_print       |NN const U8 *s|const STRLEN len
 
-AdTop  |UV     |utf8n_to_uvchr |NN const U8 *s                             \
+AdMTp  |UV     |utf8n_to_uvchr |NN const U8 *s                             \
                                |STRLEN curlen                              \
                                |NULLOK STRLEN *retlen                      \
                                |const U32 flags
-AdTop  |UV     |utf8n_to_uvchr_error|NN const U8 *s                        \
+AdMTp  |UV     |utf8n_to_uvchr_error|NN const U8 *s                        \
                                |STRLEN curlen                              \
                                |NULLOK STRLEN *retlen                      \
                                |const U32 flags                            \
@@ -1901,7 +1902,7 @@ Adm       |U8*    |uvchr_to_utf8  |NN U8 *d|UV uv
 Ap     |U8*    |uvuni_to_utf8  |NN U8 *d|UV uv
 Adm    |U8*    |uvchr_to_utf8_flags    |NN U8 *d|UV uv|UV flags
 Admx   |U8*    |uvchr_to_utf8_flags_msgs|NN U8 *d|UV uv|UV flags|NULLOK HV ** msgs
-Apod   |U8*    |uvoffuni_to_utf8_flags |NN U8 *d|UV uv|const UV flags
+AMpod  |U8*    |uvoffuni_to_utf8_flags |NN U8 *d|UV uv|const UV flags
 Apx    |U8*    |uvoffuni_to_utf8_flags_msgs|NN U8 *d|UV uv|const UV flags|NULLOK HV** msgs
 Ap     |U8*    |uvuni_to_utf8_flags    |NN U8 *d|UV uv|UV flags
 Apd    |char*  |pv_uni_display |NN SV *dsv|NN const U8 *spv|STRLEN len|STRLEN pvlim|UV flags
@@ -3131,8 +3132,8 @@ ApoP      |bool   |ckwarn_d       |U32 w
 XEopxR |STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
                                |NN const char *const bits|STRLEN size
 
-ApTodf |int    |my_snprintf    |NN char *buffer|const Size_t len|NN const char *format|...
-ApTod  |int    |my_vsnprintf   |NN char *buffer|const Size_t len|NN const char *format|va_list ap
+AMpTodf        |int    |my_snprintf    |NN char *buffer|const Size_t len|NN const char *format|...
+AMpTod |int    |my_vsnprintf   |NN char *buffer|const Size_t len|NN const char *format|va_list ap
 #ifdef USE_QUADMATH
 ApTd   |const char*    |quadmath_format_single|NN const char* format
 ApTd   |bool|quadmath_format_needed|NN const char* format
@@ -3225,10 +3226,10 @@ p       |void   |boot_core_mro
 ApoT   |void   |sys_init       |NN int* argc|NN char*** argv
 ApoT   |void   |sys_init3      |NN int* argc|NN char*** argv|NN char*** env
 ApoT   |void   |sys_term
-Apox   |const char *|cop_fetch_label|NN COP *const cop \
+AMpx   |const char *|cop_fetch_label|NN COP *const cop \
                |NULLOK STRLEN *len|NULLOK U32 *flags
 : Only used  in op.c and the perl compiler
-Apox   |void|cop_store_label \
+AMpx   |void|cop_store_label \
                |NN COP *const cop|NN const char *label|STRLEN len|U32 flags
 
 epo    |int    |keyword_plugin_standard|NN char* keyword_ptr|STRLEN keyword_len|NN OP** op_ptr

diff --git a/embed.h b/embed.h
index e59b519..506327f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -935,9 +935,6 @@
 #define whichsig_sv(a)         Perl_whichsig_sv(aTHX_ a)
 #define wrap_keyword_plugin(a,b)       Perl_wrap_keyword_plugin(aTHX_ a,b)
 #define wrap_op_checker(a,b,c) Perl_wrap_op_checker(aTHX_ a,b,c)
-#if !(defined(HAS_MEMMEM))
-#define ninstr                 Perl_ninstr
-#endif
 #if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO))
 #define csighandler            Perl_csighandler
 #endif

diff --git a/proto.h b/proto.h
index 3126397..0fc2adc 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2581,6 +2581,12 @@ PERL_CALLCONV STRLEN *   Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const ch
 PERL_CALLCONV PerlIO*  Perl_nextargv(pTHX_ GV* gv, bool nomagicopen);
 #define PERL_ARGS_ASSERT_NEXTARGV      \
        assert(gv)
+PERL_CALLCONV char*    Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend)
+                       __attribute__warn_unused_result__
+                       __attribute__pure__;
+#define PERL_ARGS_ASSERT_NINSTR        \
+       assert(big); assert(bigend); assert(little); assert(lend)
+
 PERL_CALLCONV_NO_RET void      Perl_noperl_die(const char* pat, ...)
                        __attribute__noreturn__
                        __attribute__format__(__printf__,1,2);
@@ -4063,14 +4069,6 @@ STATIC int       S_sv_2iuv_non_preserve(pTHX_ SV *const sv);
 #    endif
 #  endif
 #endif
-#if !(defined(HAS_MEMMEM))
-PERL_CALLCONV char*    Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend)
-                       __attribute__warn_unused_result__
-                       __attribute__pure__;
-#define PERL_ARGS_ASSERT_NINSTR        \
-       assert(big); assert(bigend); assert(little); assert(lend)
-
-#endif
 #if !(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))
 PERL_CALLCONV const char*      Perl_langinfo(const int item);
 #endif
@@ -4495,14 +4493,6 @@ PERL_CALLCONV void       Perl_dump_sv_child(pTHX_ SV *sv);
 #define PERL_ARGS_ASSERT_DUMP_SV_CHILD \
        assert(sv)
 #endif
-#if defined(HAS_MEMMEM)
-PERL_CALLCONV char*    Perl_ninstr(const char* big, const char* bigend, const char* little, const char* lend)
-                       __attribute__warn_unused_result__
-                       __attribute__pure__;
-#define PERL_ARGS_ASSERT_NINSTR        \
-       assert(big); assert(bigend); assert(little); assert(lend)
-
-#endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
 PERL_CALLCONV I32      Perl_do_ipcctl(pTHX_ I32 optype, SV** mark, SV** sp);
 #define PERL_ARGS_ASSERT_DO_IPCCTL     \

diff --git a/regen/embed.pl b/regen/embed.pl
index ae43c9c..d5b04b4 100755 (executable)
--- a/regen/embed.pl
+++ b/regen/embed.pl
@@ -81,7 +81,7 @@ my ($embed, $core, $ext, $api) = setup_embed();
        }
 
        my ($flags,$retval,$plain_func,@args) = @$_;
-        if ($flags =~ / ( [^AabDdEefimTOoPpRrSUWXx] ) /x) {
+        if ($flags =~ / ( [^AabDdEefiMmTOoPpRrSUWXx] ) /x) {
            die_at_end "flag $1 is not legal (for function $plain_func)";
        }
        my @nonnull;
@@ -123,6 +123,9 @@ my ($embed, $core, $ext, $api) = setup_embed();
                $retval = "PERL_CALLCONV $retval";
            }
        }
+
+       die_at_end "M flag requires p flag" if $flags =~ /M/ && $flags !~ /p/;
+
        $func = full_name($plain_func, $flags);
        $ret = "";
        $ret .= "#ifndef NO_MATHOMS\n" if $binarycompat;
@@ -302,7 +305,7 @@ sub embed_h {
        }
        my $ret = "";
        my ($flags,$retval,$func,@args) = @$_;
-       unless ($flags =~ /[om]/) {
+       unless ($flags =~ /[omM]/) {
            my $args = scalar @args;
            if ($flags =~ /T/) {
                my $full_name = full_name($func, $flags);

diff --git a/util.h b/util.h
index 71531c7..d8fa3e8 100644 (file)
--- a/util.h
+++ b/util.h
@@ -239,6 +239,8 @@ means arg not present, 1 is empty string/null byte */
 #   define ninstr(big, bigend, little, lend)                                \
             ((char *) memmem((big), (bigend) - (big),                       \
                              (little), (lend) - (little)))
+#else
+#   define ninstr(a,b,c,d) Perl_ninstr(a,b,c,d)
 #endif
 
 #ifdef __Lynx__