From: Vincent Pit <vince@profvince.com>
Date: Sun, 28 Sep 2014 15:18:22 +0000 (+0200)
Subject: Support pseudo-forks more reliably
X-Git-Tag: v0.06~4
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FThread-Cleanup.git;a=commitdiff_plain;h=edfeeb476d5446fc117243df3a5b4ce6baa82b43

Support pseudo-forks more reliably

reap.h is no longer necessary.
---

diff --git a/Cleanup.xs b/Cleanup.xs
index e88916c..919bbff 100644
--- a/Cleanup.xs
+++ b/Cleanup.xs
@@ -11,8 +11,6 @@
 
 #define TC_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
 
-#include "reap.h"
-
 STATIC void tc_callback(pTHX_ void *ud) {
  dSP;
 
@@ -30,6 +28,29 @@ STATIC void tc_callback(pTHX_ void *ud) {
  LEAVE;
 }
 
+STATIC int tc_endav_free(pTHX_ SV *sv, MAGIC *mg) {
+ SAVEDESTRUCTOR_X(tc_callback, NULL);
+
+ return 0;
+}
+
+STATIC MGVTBL tc_endav_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ tc_endav_free
+#if MGf_COPY
+ , 0
+#endif
+#if MGf_DUP
+ , 0
+#endif
+#if MGf_LOCAL
+ , 0
+#endif
+};
+
 MODULE = Thread::Cleanup            PACKAGE = Thread::Cleanup
 
 PROTOTYPES: DISABLE
@@ -37,6 +58,17 @@ PROTOTYPES: DISABLE
 void
 CLONE(...)
 PREINIT:
+ GV *gv;
 PPCODE:
- reap(3, tc_callback, NULL);
+ gv = gv_fetchpv(__PACKAGE__ "::_CLEANUP", 0, SVt_PVCV);
+ if (gv) {
+  CV *cv = GvCV(gv);
+  if (!PL_endav)
+   PL_endav = newAV();
+  av_unshift(PL_endav, 1);
+  SvREFCNT_inc(cv);
+  if (!av_store(PL_endav, 0, cv))
+   SvREFCNT_dec(cv);
+  sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &tc_endav_vtbl, NULL, 0);
+ }
  XSRETURN(0);
diff --git a/MANIFEST b/MANIFEST
index 00b94e9..cb6efab 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -6,12 +6,12 @@ META.yml
 Makefile.PL
 README
 lib/Thread/Cleanup.pm
-reap.h
 samples/try.pl
 t/00-load.t
 t/10-join.t
 t/11-detach.t
 t/20-recurse.t
 t/21-ctl.t
+t/30-pseudoforks.t
 t/lib/Thread/Cleanup/TestThreads.pm
 t/lib/VPIT/TestHelpers.pm
diff --git a/lib/Thread/Cleanup.pm b/lib/Thread/Cleanup.pm
index ebb424e..96256fd 100644
--- a/lib/Thread/Cleanup.pm
+++ b/lib/Thread/Cleanup.pm
@@ -40,6 +40,8 @@ This module allows you to hook thread destruction without fiddling with the inte
 
 It acts globally on all the threads that may spawn anywhere in your program, with the exception of the main thread.
 
+The hook will also be called when pseudo-forks (i.e. processes spawn on Windows for the C<fork> emulation) terminate.
+
 =head1 FUNCTIONS
 
 =head2 C<register>
diff --git a/reap.h b/reap.h
deleted file mode 100644
index 6b92167..0000000
--- a/reap.h
+++ /dev/null
@@ -1,81 +0,0 @@
-/* This file is part of the Thread::Cleanup Perl module.
- * See http://search.cpan.org/dist/Thread-Cleanup/ */
-
-/* This header provides a specialized version of Scope::Upper::reap that can be
- * called directly from XS.
- * See http://search.cpan.org/dist/Scope-Upper/ for details. */
-
-#ifndef REAP_H
-#define REAP_H 1
-
-#define REAP_DESTRUCTOR_SIZE 3
-
-typedef struct {
- I32    depth;
- I32   *origin;
- void (*cb)(pTHX_ void *);
- void  *ud;
- char  *dummy;
-} reap_ud;
-
-STATIC void reap_pop(pTHX_ void *);
-
-STATIC void reap_pop(pTHX_ void *ud_) {
- reap_ud *ud = ud_;
- I32 depth, *origin, mark, base;
-
- depth  = ud->depth;
- origin = ud->origin;
- mark   = origin[depth];
- base   = origin[depth - 1];
-
- if (base < mark) {
-  PL_savestack_ix = mark;
-  leave_scope(base);
- }
- PL_savestack_ix = base;
-
- if ((ud->depth = --depth) > 0) {
-  SAVEDESTRUCTOR_X(reap_pop, ud);
- } else {
-  void (*cb)(pTHX_ void *) = ud->cb;
-  void  *cb_ud             = ud->ud;
-
-  PerlMemShared_free(ud->origin);
-  PerlMemShared_free(ud);
-
-  SAVEDESTRUCTOR_X(cb, cb_ud);
- }
-}
-
-STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) {
-#define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD))
- reap_ud *ud;
- I32 i;
-
- if (depth > PL_scopestack_ix)
-  depth = PL_scopestack_ix;
-
- ud         = PerlMemShared_malloc(sizeof *ud);
- ud->depth  = depth;
- ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin);
- ud->cb     = cb;
- ud->ud     = cb_ud;
- ud->dummy  = NULL;
-
- for (i = depth; i >= 1; --i) {
-  I32 j = PL_scopestack_ix - i;
-  ud->origin[depth - i] = PL_scopestack[j];
-  PL_scopestack[j] += REAP_DESTRUCTOR_SIZE;
- }
- ud->origin[depth] = PL_savestack_ix;
-
- while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE
-                                       <= PL_scopestack[PL_scopestack_ix - 1]) {
-  save_pptr(&ud->dummy);
- }
-
- SAVEDESTRUCTOR_X(reap_pop, ud);
-}
-
-#endif /* REAP_H */
diff --git a/t/30-pseudoforks.t b/t/30-pseudoforks.t
new file mode 100644
index 0000000..2247c40
--- /dev/null
+++ b/t/30-pseudoforks.t
@@ -0,0 +1,46 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Config;
+
+use Test::More;
+
+use lib 't/lib';
+use VPIT::TestHelpers;
+
+use Thread::Cleanup;
+
+plan skip_all =>
+            'perl on Windows with pseudoforks enabled is required for this test'
+            unless $^O eq 'MSWin32' and $Config::Config{d_pseudofork};
+
+my $global_end = 0;
+END { ++$global_end }
+
+my $pid = fork;
+
+plan skip_all => 'could not fork' unless defined $pid;
+
+if ($pid) {
+ waitpid $pid, 0;
+} else {
+ plan tests => 4;
+
+ my $gd = 0;
+ my $immortal = VPIT::TestHelpers::Guard->new(sub { ++$gd });
+ $immortal->{self} = $immortal;
+
+ my $local_end = 0;
+ eval 'END { ++$local_end }';
+
+ Thread::Cleanup::register {
+  pass               'pseudo-fork destructor called';
+  is $local_end,  1, 'pseudo-fork destructor called after local END block';
+  is $global_end, 0, 'pseudo-fork destructor called before global END block';
+  is $gd,         0, 'pseudo-fork destructor called before global destruction';
+ };
+
+ exit;
+}