Test.xs

   1 /* This file is part of the Sub::Op Perl module.
   2  * See http://search.cpan.org/dist/Sub-Op/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "Sub::Op::Test"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 #include "sub_op.h"
  13
  14 STATIC HV *sub_op_test_map = NULL;
  15
  16 STATIC OP *sub_op_test_check(pTHX_ OP *o, void *ud_) {
  17  char buf[sizeof(void*)*2+1];
  18  SV *cb = ud_;
  19
  20  (void) hv_store(sub_op_test_map, buf, sprintf(buf, "%"UVxf, PTR2UV(o)), cb, 0);
  21
  22  return o;
  23 }
  24
  25 STATIC OP *sub_op_test_pp(pTHX) {
  26  dSP;
  27  dMARK;
  28  SV *cb;
  29  int i, items;
  30
  31  {
  32   char buf[sizeof(void*)*2+1];
  33   SV **svp;
  34   svp = hv_fetch(sub_op_test_map, buf, sprintf(buf, "%"UVxf, PTR2UV(PL_op)), 0);
  35   if (!svp)
  36    RETURN;
  37   cb = *svp;
  38  }
  39
  40  ENTER;
  41  SAVETMPS;
  42
  43  PUSHMARK(MARK);
  44
  45  items = call_sv(cb, G_ARRAY);
  46
  47  SPAGAIN;
  48  for (i = 0; i < items; ++i)
  49   SvREFCNT_inc(SP[-i]);
  50  PUTBACK;
  51
  52  FREETMPS;
  53  LEAVE;
  54
  55  return NORMAL;
  56 }
  57
  58 /* --- XS ------------------------------------------------------------------ */
  59
  60 MODULE = Sub::Op::Test      PACKAGE = Sub::Op::Test
  61
  62 PROTOTYPES: ENABLE
  63
  64 BOOT:
  65 {
  66  sub_op_test_map = newHV();
  67 }
  68
  69 void
  70 _init(SV *name, SV *cb)
  71 PROTOTYPE: $$
  72 PREINIT:
  73  sub_op_keyword k;
  74 PPCODE:
  75  if (SvROK(cb)) {
  76   cb = SvRV(cb);
  77   if (SvTYPE(cb) >= SVt_PVCV) {
  78    k.name  = SvPV_const(name, k.len);
  79    k.check = sub_op_test_check;
  80    k.ud    = SvREFCNT_inc(cb);
  81    k.pp    = sub_op_test_pp;
  82    sub_op_register(aTHX_ &k);
  83   }
  84  }
  85  XSRETURN(0);