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 #undef ENTERn
  15 #if defined(ENTER_with_name) && !TC_HAS_PERL(5, 11, 4)
  16 # define ENTERn(N) ENTER_with_name(N)
  17 #else
  18 # define ENTERn(N) ENTER
  19 #endif
  20
  21 #undef LEAVEn
  22 #if defined(LEAVE_with_name) && !TC_HAS_PERL(5, 11, 4)
  23 # define LEAVEn(N) LEAVE_with_name(N)
  24 #else
  25 # define LEAVEn(N) LEAVE
  26 #endif
  27
  28 STATIC void tc_callback(pTHX_ void *);
  29
  30 STATIC void tc_callback(pTHX_ void *ud) {
  31  int *level = ud;
  32  SV *id;
  33
  34  if (*level) {
  35   *level = 0;
  36   LEAVE;
  37   SAVEDESTRUCTOR_X(tc_callback, level);
  38   ENTER;
  39  } else {
  40   dSP;
  41
  42   PerlMemShared_free(level);
  43
  44   ENTER;
  45   SAVETMPS;
  46
  47   PUSHMARK(SP);
  48   PUTBACK;
  49
  50   call_pv(__PACKAGE__ "::_CLEANUP", G_VOID | G_EVAL);
  51
  52   PUTBACK;
  53
  54   FREETMPS;
  55   LEAVE;
  56  }
  57 }
  58
  59 MODULE = Thread::Cleanup            PACKAGE = Thread::Cleanup
  60
  61 PROTOTYPES: DISABLE
  62
  63 void
  64 CLONE(...)
  65 PREINIT:
  66  int *level;
  67 CODE:
  68  {
  69   level = PerlMemShared_malloc(sizeof *level);
  70   *level = 1;
  71   LEAVEn("sub");
  72   SAVEDESTRUCTOR_X(tc_callback, level);
  73   ENTERn("sub");
  74  }