From: Vincent Pit <vince@profvince.com>
Date: Mon, 4 Apr 2011 18:01:26 +0000 (+0200)
Subject: Test thread safety
X-Git-Tag: v0.09~4
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a4e4979c583c502809526c72ec00215df17baa95;p=perl%2Fmodules%2Fre-engine-Plugin.git

Test thread safety

At the same time, introduce REP_THREADSAFE and REP_FORKSAFE ; and stop
running the regexp object destructor during global destruction.
---

diff --git a/MANIFEST b/MANIFEST
index 2ed61a0..33f17a2 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -37,6 +37,7 @@ t/50-num_buff/LENGTH.t
 t/50-num_buff/STORE.t
 t/60-taint/rx.t
 t/60-taint/util.t
+t/70-threads/threads.t
 t/90-author/kwalitee.t
 t/90-author/portability-files.t
 t/90-author/pod.t
diff --git a/Makefile.PL b/Makefile.PL
index 3132b62..632a286 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -4,6 +4,15 @@ use strict;
 use warnings;
 use ExtUtils::MakeMaker;
 
+my @DEFINES;
+
+# Fork emulation got "fixed" in 5.10.1
+if ($^O eq 'MSWin32' && $^V lt v5.10.1) {
+ push @DEFINES, '-DREP_FORKSAFE=0';
+}
+
+@DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES;
+
 my $dist = 're-engine-Plugin';
 
 (my $name = $dist) =~ s{-}{::}g;
@@ -37,6 +46,7 @@ WriteMakefile(
  ABSTRACT_FROM    => 'Plugin.pod',
  VERSION_FROM     => 'Plugin.pm',
  PL_FILES         => {},
+ @DEFINES,
  PREREQ_PM        => \%PREREQ_PM,
  MIN_PERL_VERSION => 5.010,
  META_MERGE       => \%META,
diff --git a/Plugin.pod b/Plugin.pod
index 35d293b..5910f14 100644
--- a/Plugin.pod
+++ b/Plugin.pod
@@ -265,6 +265,19 @@ done it'll allow the binding of C<%+> and C<%-> and support the
 L<Tie::Hash> methods FETCH, STORE, DELETE, CLEAR, EXISTS, FIRSTKEY,
 NEXTKEY and SCALAR.
 
+=head1 CONSTANTS
+
+=head2 C<REP_THREADSAFE>
+
+True iff the module could have been built with thread-safety features
+enabled.
+
+=head2 C<REP_FORKSAFE>
+
+True iff this module could have been built with fork-safety features
+enabled. This will always be true except on Windows where it's false
+for perl 5.10.0 and below.
+
 =head1 Tainting
 
 The only way to untaint an existing variable in Perl is to use it as a
diff --git a/Plugin.xs b/Plugin.xs
index 0837321..e785d0e 100644
--- a/Plugin.xs
+++ b/Plugin.xs
@@ -19,6 +19,11 @@
 
 /* ... Thread safety and multiplicity ...................................... */
 
+/* Safe unless stated otherwise in Makefile.PL */
+#ifndef REP_FORKSAFE
+# define REP_FORKSAFE 1
+#endif
+
 #ifndef REP_MULTIPLICITY
 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
 #  define REP_MULTIPLICITY 1
@@ -437,8 +442,14 @@ Plugin_checkstr(pTHX_ REGEXP * const RX)
 void
 Plugin_free(pTHX_ REGEXP * const RX)
 {
-    struct regexp *rx = rxREGEXP(RX);
-    GET_SELF_FROM_PPRIVATE(rx->pprivate);
+    struct regexp *rx;
+    re__engine__Plugin self;
+
+    if (PL_dirty)
+        return;
+
+    rx = rxREGEXP(RX);
+    SELF_FROM_PPRIVATE(self, rx->pprivate);
 
     SvREFCNT_dec(self->pattern);
     SvREFCNT_dec(self->str);
@@ -665,7 +676,13 @@ PROTOTYPES: DISABLE
 BOOT:
 {
     if (!rep_booted++) {
+        HV *stash;
+
         PERL_HASH(rep_hash, __PACKAGE__, __PACKAGE_LEN__);
+
+        stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
+        newCONSTSUB(stash, "REP_THREADSAFE",  newSVuv(REP_THREADSAFE));
+        newCONSTSUB(stash, "REP_FORKSAFE",    newSVuv(REP_FORKSAFE));
     }
 
     rep_setup();
diff --git a/t/70-threads/threads.t b/t/70-threads/threads.t
new file mode 100644
index 0000000..d85ffda
--- /dev/null
+++ b/t/70-threads/threads.t
@@ -0,0 +1,93 @@
+#!perl
+
+use strict;
+use warnings;
+
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
+
+BEGIN {
+ my $force = $ENV{PERL_RE_ENGINE_PLUGIN_TEST_THREADS} ? 1 : !1;
+ my $t_v   = $force ? '0' : '1.67';
+ my $ts_v  = $force ? '0' : '1.14';
+ skipall 'This perl wasn\'t built to support threads'
+                                                    unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+                                                unless $force or $] >= 5.013004;
+ skipall "threads $t_v required to test thread safety"
+                                              unless eval "use threads $t_v; 1";
+ skipall "threads::shared $ts_v required to test thread safety"
+                                     unless eval "use threads::shared $ts_v; 1";
+}
+
+use Test::More; # after threads
+
+my $threads;
+BEGIN { $threads = 10 }
+
+BEGIN {
+ require re::engine::Plugin;
+ skipall 'This re::engine::Plugin isn\'t thread safe'
+                                    unless re::engine::Plugin::REP_THREADSAFE();
+ plan tests => 2 * 2 * $threads + 1;
+ defined and diag "Using threads $_"         for $threads::VERSION;
+ defined and diag "Using threads::shared $_" for $threads::shared::VERSION;
+}
+
+my $matches : shared = '';
+
+use re::engine::Plugin comp => sub {
+ my ($re) = @_;
+
+ my $pat = $re->pattern;
+
+ $re->callbacks(
+  exec => sub {
+   my ($re, $str) = @_;
+
+   {
+    lock $matches;
+    $matches .= "$str==$pat\n";
+   }
+
+   return $str == $pat;
+  },
+ );
+};
+
+sub try {
+ my $tid = threads->tid;
+
+ my $rx = qr/$tid/;
+
+ ok $tid =~ $rx, "'$tid' is matched in thread $tid";
+
+ my $wrong = $tid + 1;
+ ok $wrong !~ $rx, "'$wrong' is not matched in thread $tid";
+
+ return;
+}
+
+no re::engine::Plugin;
+
+my @tids = map threads->create(\&try), 1 .. $threads;
+
+$_->join for @tids;
+
+my %matches = map { $_ => 1 }
+               grep length,
+                split /\n/,
+                 do { lock $matches; $matches };
+
+is keys(%matches), 2 * $threads, 'regexps matched the correct number of times';
+
+for my $i (1 .. $threads) {
+ ok $matches{"$i==$i"}, "match '$i==$i' was correctly executed";
+ my $j = $i + 1;
+ ok $matches{"$j==$i"}, "match '$j==$i' was correctly executed";
+}