This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge wrap_keyword_plugin() into blead
authorLukas Mai <l.mai@web.de>
Sat, 11 Nov 2017 10:19:05 +0000 (11:19 +0100)
committerLukas Mai <l.mai@web.de>
Sat, 11 Nov 2017 10:20:01 +0000 (11:20 +0100)
15 files changed:
MANIFEST
dosish.h
embed.fnc
embed.h
embedvar.h
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/keyword_plugin_threads.t [new file with mode: 0644]
perl.c
perl.h
perlapi.h
perlvars.h
pod/perldelta.pod
proto.h
toke.c
unixish.h

index 7fcd227..7df52ed 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4325,6 +4325,7 @@ ext/XS-APItest/t/hash.t           XS::APItest: tests for hash related APIs
 ext/XS-APItest/t/join_with_space.t     test op_convert_list
 ext/XS-APItest/t/keyword_multiline.t   test keyword plugin parsing across lines
 ext/XS-APItest/t/keyword_plugin.t      test keyword plugin mechanism
+ext/XS-APItest/t/keyword_plugin_threads.t      test keyword plugin loading from multiple threads
 ext/XS-APItest/t/labelconst.aux        auxiliary file for label test
 ext/XS-APItest/t/labelconst.t  test recursive descent label parsing
 ext/XS-APItest/t/labelconst_utf8.aux   auxiliary file for label test in UTF-8
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)
index ffdc56c..8bf1545 100644 (file)
@@ -1242,6 +1242,7 @@ static int my_keyword_plugin(pTHX_
        *op_ptr = parse_join_with_space();
        return KEYWORD_PLUGIN_EXPR;
     } else {
+        assert(next_keyword_plugin != my_keyword_plugin);
        return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
     }
 }
@@ -3893,8 +3894,7 @@ BOOT:
     hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
     hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
     hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
-    next_keyword_plugin = PL_keyword_plugin;
-    PL_keyword_plugin = my_keyword_plugin;
+    wrap_keyword_plugin(my_keyword_plugin, &next_keyword_plugin);
 }
 
 void
diff --git a/ext/XS-APItest/t/keyword_plugin_threads.t b/ext/XS-APItest/t/keyword_plugin_threads.t
new file mode 100644 (file)
index 0000000..db23ce7
--- /dev/null
@@ -0,0 +1,32 @@
+#!perl
+use strict;
+use warnings;
+
+require '../../t/test.pl';
+
+use Config;
+if (!$Config{useithreads}) {
+    skip_all("keyword_plugin thread test requires threads");
+}
+
+plan(1);
+
+fresh_perl_is( <<'----', <<'====', {}, "loading XS::APItest in threads works");
+use strict;
+use warnings;
+
+use threads;
+
+require '../../t/test.pl';
+watchdog(5);
+
+for my $t (1 .. 3) {
+    threads->create(sub {
+        require XS::APItest;
+    })->join;
+}
+
+print "all is well\n";
+----
+all is well
+====
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 */
index 1ba60a6..023b55a 100644 (file)
@@ -485,6 +485,15 @@ would be (4,6,1). If the string contains characters such as C<\x80>, whose
 representation changes under utf8, two sets of strings plus lengths are
 precomputed and stored.
 
+=item *
+
+Direct access to L<C<PL_keyword_plugin>|perlapi/PL_keyword_plugin> is not
+safe in the presence of multithreading. A new
+L<C<wrap_keyword_plugin>|perlapi/wrap_keyword_plugin> function has been
+added to allow XS modules to safely define custom keywords even when
+loaded from a thread, analoguous to L<C<PL_check>|perlapi/PL_check> /
+L<C<wrap_op_checker>|perlapi/wrap_op_checker>.
+
 =back
 
 =head1 Selected Bug Fixes
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