Make the module threadsafe by adding a CLONE method that clones the global state...

diff --git a/MANIFEST b/MANIFEST
index 77a5fff44300768d892c26c4c505b964cab85414..fb5f7abd7139cf790a1a005bf629d58ee708770b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -31,6 +31,7 @@ t/31-array.t
 t/32-hash.t
 t/33-code.t
 t/34-glob.t
+t/40-threads.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t

diff --git a/Magic.xs b/Magic.xs
index 82bf5dd022c5a614e9f15095f7f72a1c7cdd0453..89df570ec4d896ae54599ad0408221dccbcb1a64 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -45,10 +45,19 @@
 #endif
 
 #ifndef dMY_CXT
-# define MY_CXT vmg_globaldata
 # define dMY_CXT
+# undef  MY_CXT
+# define MY_CXT vmg_globaldata
+# undef  START_MY_CXT
 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
+# undef  MY_CXT_INIT
 # define MY_CXT_INIT
+# undef  MY_CXT_CLONE
+# undef  aMY_CXT
+# undef  pMY_CXT
+# define VMG_THREADSAFE 0
+#else
+# define VMG_THREADSAFE 1
 #endif
 
 #ifndef PERL_MAGIC_ext
@@ -129,6 +138,23 @@ typedef struct {
 
 START_MY_CXT
 
+STATIC void vmg_cxt_init
+#if defined(pMY_CXT) && defined(aMY_CXT)
+ (pTHX_ pMY_CXT) {
+# define vmg_cxt_init() vmg_cxt_init(aTHX_ aMY_CXT)
+#else
+ (pTHX) {
+ dMY_CXT;
+# define vmg_cxt_init() vmg_cxt_init(aTHX)
+#endif
+ MY_CXT.wizz = newHV();
+#ifdef USE_ITHREADS
+ HvSHAREKEYS_off(MY_CXT.wizz);
+#endif
+ MY_CXT.count = 0;
+ return;
+}
+
 /* --- Signatures ---------------------------------------------------------- */
 
 #define SIG_MIN ((U16) (1u << 8))
@@ -700,8 +726,7 @@ BOOT:
 {
  HV *stash;
  MY_CXT_INIT;
- MY_CXT.wizz = newHV();
- MY_CXT.count = 0;
+ vmg_cxt_init();
  stash = gv_stashpv(__PACKAGE__, 1);
  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
@@ -717,8 +742,18 @@ BOOT:
  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
+ newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));
 }
 
+void
+CLONE(...)
+PROTOTYPE: DISABLE
+CODE:
+#ifdef MY_CXT_CLONE
+ MY_CXT_CLONE;
+ vmg_cxt_init();
+#endif
+
 SV *_wizard(...)
 PROTOTYPE: DISABLE
 PREINIT:
@@ -802,7 +837,7 @@ CODE:
 
  hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0);
  ++MY_CXT.count;
- 
+
  RETVAL = newRV_noinc(sv);
 OUTPUT:
  RETVAL

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index ea1836e181eda823b0c13046e3f57125e2737434..af2762db066577e372fc7b918b593c468a377490 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -213,6 +213,10 @@ True for perls that don't call 'len' magic when taking the C<length> of a magica
 
 The perl patchlevel this module was built with, or C<0> for non-debugging perls.
 
+=head2 C<VMG_THREADSAFE>
+
+True iff this module could have been built with thread-safety features enabled.
+
 =head1 FUNCTIONS
 
 =cut
@@ -345,7 +349,8 @@ our %EXPORT_TAGS    = (
  'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/,
                qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR/,
                qw/VMG_COMPAT_SCALAR_LENGTH_NOLEN/,
-               qw/VMG_PERL_PATCHLEVEL/ ]
+               qw/VMG_PERL_PATCHLEVEL/,
+               qw/VMG_THREADSAFE/ ]
 );
 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];

diff --git a/t/01-import.t b/t/01-import.t
index 81e2e3fbd8931b74f67eeb330402f110ed480f7d..05f7e9bb279c47020fdc5355071b31a361bc8f28 100644 (file)
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,11 +3,11 @@
 use strict;
 use warnings;
 
-use Test::More tests => 17;
+use Test::More tests => 18;
 
 require Variable::Magic;
 
-for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_PERL_PATCHLEVEL/) {
+for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_PERL_PATCHLEVEL VMG_THREADSAFE/) {
  eval { Variable::Magic->import($_) };
  is($@, '', 'import ' . $_);
 }

diff --git a/t/40-threads.t b/t/40-threads.t
new file mode 100644 (file)
index 0000000..9e4c11b
--- /dev/null
+++ b/t/40-threads.t
@@ -0,0 +1,60 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use threads; # Before Test::More
+use threads::shared;
+
+use Test::More;
+
+use Variable::Magic qw/wizard cast dispell getdata VMG_THREADSAFE/;
+
+if (VMG_THREADSAFE) {
+ plan tests => 2 * 16 + 1;
+} else {
+ plan skip_all => 'This Variable::Magic isn\'t thread safe';
+}
+
+my $destroyed : shared = 0;
+
+sub try {
+ my $tid = threads->tid();
+ my $c   = 0;
+ my $wiz = eval {
+  wizard get  => sub { ++$c },
+         data => sub { $_[1] + $tid },
+         free => sub { ++$destroyed };
+ };
+ is($@,     '',    "wizard in thread $tid doesn't croak");
+ isnt($wiz, undef, "wizard in thread $tid is defined");
+ is($c,     0,     "wizard in thread $tid doesn't trigger magic");
+ my $a = 3;
+ my $res = eval { cast $a, $wiz, sub { 5 }->() };
+ is($@, '', "cast in thread $tid doesn't croak");
+ is($c, 0,  "cast in thread $tid doesn't trigger magic");
+ my $b;
+ eval { $b = $a };
+ is($@, '', "get in thread $tid doesn't croak");
+ is($b, 3,  "get in thread $tid returns the right thing");
+ is($c, 1,  "get in thread $tid triggers magic");
+ my $d = eval { getdata $a, $wiz };
+ is($@, '',       "getdata in thread $tid doesn't croak");
+ is($d, 5 + $tid, "getdata in thread $tid returns the right thing");
+ is($c, 1,        "getdata in thread $tid doesn't trigger magic");
+ $res = eval { dispell $a, $wiz };
+ is($@, '', "dispell in thread $tid doesn't croak");
+ is($c, 1,  "dispell in thread $tid doesn't trigger magic");
+ undef $b;
+ eval { $b = $a };
+ is($@, '', "get in thread $tid after dispell doesn't croak");
+ is($b, 3,  "get in thread $tid after dispell returns the right thing");
+ is($c, 1,  "get in thread $tid after dispell doesn't trigger magic");
+ return;
+}
+
+my @t = map { threads->create(\&try) } 1 .. 2;
+$t[0]->join;
+$t[1]->join;
+
+is($destroyed, 0, 'destructors didn\'t fired');