Support pseudo-forks more reliably
[perl/modules/Thread-Cleanup.git] / Cleanup.xs
1 /* This file is part of the Thread::Cleanup Perl module.
2  * See http://search.cpan.org/dist/Thread-Cleanup/ */
3
4 #define PERL_NO_GET_CONTEXT
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #define __PACKAGE__     "Thread::Cleanup"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
11
12 #define TC_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
13
14 STATIC void tc_callback(pTHX_ void *ud) {
15  dSP;
16
17  ENTER;
18  SAVETMPS;
19
20  PUSHMARK(SP);
21  PUTBACK;
22
23  call_pv(__PACKAGE__ "::_CLEANUP", G_VOID | G_EVAL);
24
25  PUTBACK;
26
27  FREETMPS;
28  LEAVE;
29 }
30
31 STATIC int tc_endav_free(pTHX_ SV *sv, MAGIC *mg) {
32  SAVEDESTRUCTOR_X(tc_callback, NULL);
33
34  return 0;
35 }
36
37 STATIC MGVTBL tc_endav_vtbl = {
38  0,
39  0,
40  0,
41  0,
42  tc_endav_free
43 #if MGf_COPY
44  , 0
45 #endif
46 #if MGf_DUP
47  , 0
48 #endif
49 #if MGf_LOCAL
50  , 0
51 #endif
52 };
53
54 MODULE = Thread::Cleanup            PACKAGE = Thread::Cleanup
55
56 PROTOTYPES: DISABLE
57
58 void
59 CLONE(...)
60 PREINIT:
61  GV *gv;
62 PPCODE:
63  gv = gv_fetchpv(__PACKAGE__ "::_CLEANUP", 0, SVt_PVCV);
64  if (gv) {
65   CV *cv = GvCV(gv);
66   if (!PL_endav)
67    PL_endav = newAV();
68   av_unshift(PL_endav, 1);
69   SvREFCNT_inc(cv);
70   if (!av_store(PL_endav, 0, cv))
71    SvREFCNT_dec(cv);
72   sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &tc_endav_vtbl, NULL, 0);
73  }
74  XSRETURN(0);