From: Vincent Pit Date: Fri, 19 Sep 2008 21:53:44 +0000 (+0200) Subject: Make the module threadsafe by adding a CLONE method that clones the global state... X-Git-Tag: v0.20~16 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=201d2874479e003bb82662085516a07aa04391e2 Make the module threadsafe by adding a CLONE method that clones the global state. Test it with t/40-threads.t. Export the thread-safety status through VMG_THREADSAFE --- diff --git a/MANIFEST b/MANIFEST index 77a5fff..fb5f7ab 100644 --- 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 82bf5dd..89df570 100644 --- 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 ea1836e..af2762d 100644 --- 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 of a magica The perl patchlevel this module was built with, or C<0> for non-debugging perls. +=head2 C + +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 81e2e3f..05f7e9b 100644 --- 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 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');