In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/6cc7638e57c54706dc2d698d9b2f9f769c17ffb4?hp=a3371546646b4c0f722f2659beac614649d6cfd5>
- Log -----------------------------------------------------------------
commit 6cc7638e57c54706dc2d698d9b2f9f769c17ffb4
Merge: a337154664 ee5287f665
Author: Lukas Mai <l....@web.de>
Date: Sat Nov 11 11:19:05 2017 +0100
Merge wrap_keyword_plugin() into blead
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
dosish.h | 7 +--
embed.fnc | 1 +
embed.h | 1 +
embedvar.h | 2 +
ext/XS-APItest/APItest.xs | 4 +-
ext/XS-APItest/t/keyword_plugin_threads.t | 32 ++++++++++++++
perl.c | 1 +
perl.h | 12 +++++
perlapi.h | 2 +
perlvars.h | 6 +++
pod/perldelta.pod | 9 ++++
proto.h | 3 ++
toke.c | 73 +++++++++++++++++++++++++++++++
unixish.h | 15 ++++---
15 files changed, 157 insertions(+), 12 deletions(-)
create mode 100644 ext/XS-APItest/t/keyword_plugin_threads.t
diff --git a/MANIFEST b/MANIFEST
index 7fcd227fae..7df52ed8c9 100644
--- 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
diff --git a/dosish.h b/dosish.h
index 9fd43ea682..16ee9b7359 100644
--- a/dosish.h
+++ b/dosish.h
@@ -48,9 +48,10 @@
#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
diff --git a/embed.fnc b/embed.fnc
index be12f88024..6269498ec7 100644
--- 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 ea05c91343..46c59b5b4e 100644
--- a/embed.h
+++ b/embed.h
@@ -771,6 +771,7 @@
#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
diff --git a/embedvar.h b/embedvar.h
index 898b71cd31..1a146c4d54 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -401,6 +401,8 @@
#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/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index ffdc56c38e..8bf1545b63 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -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
index 0000000000..db23ce7d58
--- /dev/null
+++ b/ext/XS-APItest/t/keyword_plugin_threads.t
@@ -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 454cc756ba..bf48b31493 100644
--- 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 631c4f0e29..23f209c013 100644
--- 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 */
diff --git a/perlapi.h b/perlapi.h
index af0c2d593b..c461593dae 100644
--- 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
diff --git a/perlvars.h b/perlvars.h
index b184b89419..472ae2dbb9 100644
--- a/perlvars.h
+++ b/perlvars.h
@@ -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/pod/perldelta.pod b/pod/perldelta.pod
index 1ba60a6628..023b55ad45 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -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 bc24aee4fd..8c58a086bb 100644
--- 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 18eda7a3c1..c8ca63adbb 100644
--- 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)
diff --git a/unixish.h b/unixish.h
index 4cd8e43833..cd869cd240 100644
--- 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
--
Perl5 Master Repository
