add wrap_keyword_plugin function (RT #132413)
authorLukas Mai <l.mai@web.de>
Wed, 8 Nov 2017 23:59:53 +0000 (00:59 +0100)
committerLukas Mai <l.mai@web.de>
Sat, 11 Nov 2017 10:16:31 +0000 (11:16 +0100)
dosish.h
embed.fnc
embed.h
embedvar.h
perl.c
perl.h
perlapi.h
perlvars.h
proto.h
toke.c
unixish.h

index 9fd43ea..16ee9b7 100644 (file)
--- a/dosish.h
+++ b/dosish.h
 #endif
 
 #ifndef PERL_SYS_TERM_BODY
-#  define PERL_SYS_TERM_BODY()                              \
-    HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM;                 \
-    OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM; LOCALE_TERM;
+#  define PERL_SYS_TERM_BODY()                         \
+    HINTS_REFCNT_TERM; KEYWORD_PLUGIN_MUTEX_TERM;      \
+    OP_CHECK_MUTEX_TERM; OP_REFCNT_TERM; PERLIO_TERM;  \
+    MALLOC_TERM; LOCALE_TERM;
 #endif
 #define dXSUB_SYS dNOOP
 
index be12f88..6269498 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1185,6 +1185,7 @@ Apd       |void   |cv_set_call_checker_flags|NN CV *cv \
                                          |NN Perl_call_checker ckfun \
                                          |NN SV *ckobj|U32 ckflags
 Apd    |void   |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p
+AMpd   |void   |wrap_keyword_plugin|NN Perl_keyword_plugin_t new_plugin|NN Perl_keyword_plugin_t *old_plugin_p
 ApR    |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
 Ap     |char*  |scan_vstring   |NN const char *s|NN const char *const e \
                                |NN SV *sv
diff --git a/embed.h b/embed.h
index ea05c91..46c59b5 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define whichsig_pv(a)         Perl_whichsig_pv(aTHX_ a)
 #define whichsig_pvn(a,b)      Perl_whichsig_pvn(aTHX_ a,b)
 #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
index 898b71c..1a146c4 100644 (file)
 #define PL_Ghints_mutex                (my_vars->Ghints_mutex)
 #define PL_keyword_plugin      (my_vars->Gkeyword_plugin)
 #define PL_Gkeyword_plugin     (my_vars->Gkeyword_plugin)
+#define PL_keyword_plugin_mutex        (my_vars->Gkeyword_plugin_mutex)
+#define PL_Gkeyword_plugin_mutex       (my_vars->Gkeyword_plugin_mutex)
 #define PL_locale_mutex                (my_vars->Glocale_mutex)
 #define PL_Glocale_mutex       (my_vars->Glocale_mutex)
 #define PL_malloc_mutex                (my_vars->Gmalloc_mutex)
diff --git a/perl.c b/perl.c
index 454cc75..bf48b31 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -92,6 +92,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl)
        PERL_SET_THX(my_perl);
        OP_REFCNT_INIT;
        OP_CHECK_MUTEX_INIT;
+        KEYWORD_PLUGIN_MUTEX_INIT;
        HINTS_REFCNT_INIT;
         LOCALE_INIT;
        MUTEX_INIT(&PL_dollarzero_mutex);
diff --git a/perl.h b/perl.h
index 631c4f0..23f209c 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5420,6 +5420,18 @@ typedef struct am_table_short AMTS;
 
 #define PERLDB_LINE_OR_SAVESRC (PL_perldb & (PERLDBf_LINE | PERLDBf_SAVESRC))
 
+#ifdef USE_ITHREADS
+#  define KEYWORD_PLUGIN_MUTEX_INIT    MUTEX_INIT(&PL_keyword_plugin_mutex)
+#  define KEYWORD_PLUGIN_MUTEX_LOCK    MUTEX_LOCK(&PL_keyword_plugin_mutex)
+#  define KEYWORD_PLUGIN_MUTEX_UNLOCK  MUTEX_UNLOCK(&PL_keyword_plugin_mutex)
+#  define KEYWORD_PLUGIN_MUTEX_TERM    MUTEX_DESTROY(&PL_keyword_plugin_mutex)
+#else
+#  define KEYWORD_PLUGIN_MUTEX_INIT    NOOP
+#  define KEYWORD_PLUGIN_MUTEX_LOCK    NOOP
+#  define KEYWORD_PLUGIN_MUTEX_UNLOCK  NOOP
+#  define KEYWORD_PLUGIN_MUTEX_TERM    NOOP
+#endif
+
 #ifdef USE_LOCALE
 /* These locale things are all subject to change */
 
index af0c2d5..c461593 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -129,6 +129,8 @@ END_EXTERN_C
 #define PL_hints_mutex         (*Perl_Ghints_mutex_ptr(NULL))
 #undef  PL_keyword_plugin
 #define PL_keyword_plugin      (*Perl_Gkeyword_plugin_ptr(NULL))
+#undef  PL_keyword_plugin_mutex
+#define PL_keyword_plugin_mutex        (*Perl_Gkeyword_plugin_mutex_ptr(NULL))
 #undef  PL_locale_mutex
 #define PL_locale_mutex                (*Perl_Glocale_mutex_ptr(NULL))
 #undef  PL_malloc_mutex
index b184b89..472ae2d 100644 (file)
@@ -224,9 +224,15 @@ at a chain of handler functions, all of which have an opportunity to
 handle keywords, and only the last function in the chain (built into
 the Perl core) will normally return C<KEYWORD_PLUGIN_DECLINE>.
 
+For thread safety, modules should not set this variable directly.
+Instead, use the function L</wrap_keyword_plugin>.
+
 =cut
 */
 
+#if defined(USE_ITHREADS)
+PERLVAR(G, keyword_plugin_mutex, perl_mutex)   /* Mutex for PL_keyword_plugin */
+#endif
 PERLVARI(G, keyword_plugin, Perl_keyword_plugin_t, Perl_keyword_plugin_standard)
 
 PERLVARI(G, op_sequence, HV *, NULL)   /* dump.c */
diff --git a/proto.h b/proto.h
index bc24aee..8c58a08 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3764,6 +3764,9 @@ PERL_CALLCONV I32 Perl_whichsig_pvn(pTHX_ const char* sig, STRLEN len);
 PERL_CALLCONV I32      Perl_whichsig_sv(pTHX_ SV* sigsv);
 #define PERL_ARGS_ASSERT_WHICHSIG_SV   \
        assert(sigsv)
+PERL_CALLCONV void     Perl_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p);
+#define PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN   \
+       assert(new_plugin); assert(old_plugin_p)
 PERL_CALLCONV void     Perl_wrap_op_checker(pTHX_ Optype opcode, Perl_check_t new_checker, Perl_check_t *old_checker_p);
 #define PERL_ARGS_ASSERT_WRAP_OP_CHECKER       \
        assert(new_checker); assert(old_checker_p)
diff --git a/toke.c b/toke.c
index 18eda7a..c8ca63a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -12072,6 +12072,79 @@ Perl_keyword_plugin_standard(pTHX_
     return KEYWORD_PLUGIN_DECLINE;
 }
 
+/*
+=for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p
+
+Puts a C function into the chain of keyword plugins.  This is the
+preferred way to manipulate the L</PL_keyword_plugin> variable.
+C<new_plugin> is a pointer to the C function that is to be added to the
+keyword plugin chain, and C<old_plugin_p> points to the storage location
+where a pointer to the next function in the chain will be stored.  The
+value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
+while the value previously stored there is written to C<*old_plugin_p>.
+
+L</PL_keyword_plugin> is global to an entire process, and a module wishing
+to hook keyword parsing may find itself invoked more than once per
+process, typically in different threads.  To handle that situation, this
+function is idempotent.  The location C<*old_plugin_p> must initially
+(once per process) contain a null pointer.  A C variable of static
+duration (declared at file scope, typically also marked C<static> to give
+it internal linkage) will be implicitly initialised appropriately, if it
+does not have an explicit initialiser.  This function will only actually
+modify the plugin chain if it finds C<*old_plugin_p> to be null.  This
+function is also thread safe on the small scale.  It uses appropriate
+locking to avoid race conditions in accessing L</PL_keyword_plugin>.
+
+When this function is called, the function referenced by C<new_plugin>
+must be ready to be called, except for C<*old_plugin_p> being unfilled.
+In a threading situation, C<new_plugin> may be called immediately, even
+before this function has returned.  C<*old_plugin_p> will always be
+appropriately set before C<new_plugin> is called.  If C<new_plugin>
+decides not to do anything special with the identifier that it is given
+(which is the usual case for most calls to a keyword plugin), it must
+chain the plugin function referenced by C<*old_plugin_p>.
+
+Taken all together, XS code to install a keyword plugin should typically
+look something like this:
+
+    static Perl_keyword_plugin_t next_keyword_plugin;
+    static OP *my_keyword_plugin(pTHX_
+        char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
+    {
+        if (memEQs(keyword_ptr, keyword_len,
+                   "my_new_keyword")) {
+            ...
+        } else {
+            return next_keyword_plugin(aTHX_
+                keyword_ptr, keyword_len, op_ptr);
+        }
+    }
+    BOOT:
+        wrap_keyword_plugin(my_keyword_plugin,
+                            &next_keyword_plugin);
+
+Direct access to L</PL_keyword_plugin> should be avoided.
+
+=cut
+*/
+
+void
+Perl_wrap_keyword_plugin(pTHX_
+    Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
+{
+    dVAR;
+
+    PERL_UNUSED_CONTEXT;
+    PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
+    if (*old_plugin_p) return;
+    KEYWORD_PLUGIN_MUTEX_LOCK;
+    if (!*old_plugin_p) {
+        *old_plugin_p = PL_keyword_plugin;
+        PL_keyword_plugin = new_plugin;
+    }
+    KEYWORD_PLUGIN_MUTEX_UNLOCK;
+}
+
 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
 static void
 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
index 4cd8e43..cd869cd 100644 (file)
--- a/unixish.h
+++ b/unixish.h
@@ -138,9 +138,10 @@ int afstat(int fd, struct stat *statb);
 #if defined(__amigaos4__)
 #  define PERL_SYS_INIT_BODY(c,v)                                      \
        MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT; amigaos4_init_fork_array(); amigaos4_init_environ_sema();
-#  define PERL_SYS_TERM_BODY()                              \
-    HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM;                 \
-    OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM; LOCALE_TERM;  \
+#  define PERL_SYS_TERM_BODY()                         \
+    HINTS_REFCNT_TERM; KEYWORD_PLUGIN_MUTEX_TERM;      \
+    OP_CHECK_MUTEX_TERM; OP_REFCNT_TERM; PERLIO_TERM;  \
+    MALLOC_TERM; LOCALE_TERM;                          \
     amigaos4_dispose_fork_array();
 #endif
 
@@ -150,10 +151,10 @@ int afstat(int fd, struct stat *statb);
 #endif
 
 #ifndef PERL_SYS_TERM_BODY
-#  define PERL_SYS_TERM_BODY()                      \
-    HINTS_REFCNT_TERM; OP_CHECK_MUTEX_TERM;         \
-    OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM;       \
-    LOCALE_TERM;
+#  define PERL_SYS_TERM_BODY()                         \
+    HINTS_REFCNT_TERM; KEYWORD_PLUGIN_MUTEX_TERM;      \
+    OP_CHECK_MUTEX_TERM; OP_REFCNT_TERM; PERLIO_TERM;  \
+    MALLOC_TERM; LOCALE_TERM;
 
 #endif