Support pseudo-forks more reliably

reap.h is no longer necessary.

diff --git a/Cleanup.xs b/Cleanup.xs
index e88916c2c52be88447a381a336270125ec0e5668..919bbff306c4be383e828301f972c66ff2617572 100644 (file)
--- 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 00b94e964e6f975e2a8b6fb1b9fd84646718fa8f..cb6efabf91641fe20c414d5a9f34f1e53eb3e97e 100644 (file)
--- 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 ebb424ee67941871692ee4644bb5c5beb0d54e5d..96256fd4ea227484a841e01d07da822884123b71 100644 (file)
--- 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 (file)
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 (file)
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;
+}