Sub-Op-Test/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 SV *sub_op_test_cb = NULL;
  15
  16 STATIC OP *sub_op_test_pp(pTHX) {
  17  dSP;
  18  dMARK;
  19  int i, items;
  20
  21  ENTER;
  22  SAVETMPS;
  23
  24  PUSHMARK(MARK);
  25
  26  items = call_sv(sub_op_test_cb, G_ARRAY);
  27
  28  SPAGAIN;
  29  for (i = 0; i < items; ++i)
  30   SvREFCNT_inc(SP[-i]);
  31  PUTBACK;
  32
  33  FREETMPS;
  34  LEAVE;
  35
  36  return NORMAL;
  37 }
  38
  39 /* --- XS ------------------------------------------------------------------ */
  40
  41 MODULE = Sub::Op::Test      PACKAGE = Sub::Op::Test
  42
  43 PROTOTYPES: ENABLE
  44
  45 void
  46 _init(SV *name)
  47 PROTOTYPE: $
  48 PREINIT:
  49  sub_op_keyword k;
  50 PPCODE:
  51  k.name  = SvPV_const(name, k.len);
  52  k.check = 0;
  53  k.pp    = sub_op_test_pp;
  54  sub_op_register(aTHX_ &k);
  55  XSRETURN(0);
  56
  57 void
  58 _callback(SV *cb)
  59 PROTOTYPE: $
  60 PPCODE:
  61  if (SvROK(cb)) {
  62   cb = SvRV(cb);
  63   if (SvTYPE(cb) >= SVt_PVCV) {
  64    SvREFCNT_dec(sub_op_test_cb);
  65    sub_op_test_cb = SvREFCNT_inc(cb);
  66   }
  67  }
  68  XSRETURN(0);