From: Vincent Pit <vince@profvince.com>
Date: Mon, 29 Sep 2014 20:02:18 +0000 (+0200)
Subject: Do nothing after that the thread local storage has been freed
X-Git-Tag: v0.33~1
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=60471c15bcd3a1e35825dba496ecd4332ea08316

Do nothing after that the thread local storage has been freed

This de facto disables the pragma for code eval'd during global
destruction of a thread or a pseudo-fork.
---

diff --git a/indirect.xs b/indirect.xs
index 7c264c5..3a977f0 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -403,7 +403,13 @@ get_enclosing_cv:
 STATIC SV *indirect_tag(pTHX_ SV *value) {
 #define indirect_tag(V) indirect_tag(aTHX_ (V))
  indirect_hint_t *h;
- SV *code = NULL;
+ SV              *code = NULL;
+#if I_THREADSAFE
+ dMY_CXT;
+
+ if (!MY_CXT.tbl)
+  return newSViv(0);
+#endif /* I_THREADSAFE */
 
  if (SvROK(value)) {
   value = SvRV(value);
@@ -424,13 +430,10 @@ STATIC SV *indirect_tag(pTHX_ SV *value) {
 #endif /* !I_HINT_STRUCT */
 
 #if I_THREADSAFE
- {
-  dMY_CXT;
-  /* We only need for the key to be an unique tag for looking up the value later
-   * Allocated memory provides convenient unique identifiers, so that's why we
-   * use the hint as the key itself. */
-  ptable_hints_store(MY_CXT.tbl, h, h);
- }
+ /* We only need for the key to be an unique tag for looking up the value later
+  * Allocated memory provides convenient unique identifiers, so that's why we
+  * use the hint as the key itself. */
+ ptable_hints_store(MY_CXT.tbl, h, h);
 #endif /* I_THREADSAFE */
 
  return newSViv(PTR2IV(h));
@@ -443,6 +446,11 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) {
  dMY_CXT;
 #endif
 
+#if I_THREADSAFE
+ if (!MY_CXT.tbl)
+  return NULL;
+#endif /* I_THREADSAFE */
+
  h = INT2PTR(indirect_hint_t *, SvIVX(hint));
 #if I_THREADSAFE
  h = ptable_fetch(MY_CXT.tbl, h);
@@ -504,6 +512,9 @@ STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t lin
  STRLEN len;
  dMY_CXT;
 
+ /* No need to check for MY_CXT.map != NULL because this code path is always
+  * guarded by indirect_hint(). */
+
  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
   Newx(oi, 1, indirect_op_info_t);
   ptable_store(MY_CXT.map, o, oi);
@@ -534,6 +545,9 @@ STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
  dMY_CXT;
 
+ /* No need to check for MY_CXT.map != NULL because this code path is always
+  * guarded by indirect_hint(). */
+
  return ptable_fetch(MY_CXT.map, o);
 }
 
@@ -541,7 +555,8 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) {
 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
  dMY_CXT;
 
- ptable_delete(MY_CXT.map, o);
+ if (MY_CXT.map)
+  ptable_delete(MY_CXT.map, o);
 }
 
 /* --- Check functions ----------------------------------------------------- */
diff --git a/lib/indirect.pm b/lib/indirect.pm
index 80ccfae..4426f7b 100644
--- a/lib/indirect.pm
+++ b/lib/indirect.pm
@@ -250,6 +250,8 @@ If you use C<perl> 5.12 or greater, those constructs are correctly reported.
 With 5.8 perls, the pragma does not propagate into C<eval STRING>.
 This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10.
 
+Indirect constructs that appear in code C<eval>'d during the global destruction phase of a spawned thread or pseudo-fork (the processes used internally for the C<fork> emulation on Windows) are not reported.
+
 The search for indirect method calls happens before constant folding.
 Hence C<my $x = new Class if 0> will be caught.
 
diff --git a/t/41-threads-teardown.t b/t/41-threads-teardown.t
index 419ce9d..6c4814c 100644
--- a/t/41-threads-teardown.t
+++ b/t/41-threads-teardown.t
@@ -7,7 +7,7 @@ use lib 't/lib';
 use VPIT::TestHelpers;
 use indirect::TestThreads;
 
-use Test::Leaner tests => 1;
+use Test::Leaner tests => 3;
 
 SKIP:
 {
@@ -31,3 +31,36 @@ SKIP:
  RUN
  is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault';
 }
+
+{
+ my $status = run_perl <<' RUN';
+  use threads;
+  BEGIN { require indirect; }
+  sub X::DESTROY { eval 'no indirect; 1'; exit 1 if $@ }
+  threads->create(sub {
+   my $x = bless { }, 'X';
+   $x->{self} = $x;
+   return;
+  })->join;
+  exit $code;
+ RUN
+ is $status, 0, 'indirect can be loaded in eval STRING during global destruction at the end of a thread';
+}
+
+{
+ my $status = run_perl <<' RUN';
+  use threads;
+  use threads::shared;
+  my $code : shared;
+  $code = 0;
+  no indirect cb => sub { lock $code; ++$code };
+  sub X::DESTROY { eval $_[0]->{code} }
+  threads->create(sub {
+   my $x = bless { code => 'new Z' }, 'X';
+   $x->{self} = $x;
+   return;
+  })->join;
+  exit $code;
+ RUN
+ is $status, 0, 'indirect does not check eval STRING during global destruction at the end of a thread';
+}