]> git.vpit.fr Git - perl/modules/Sub-Op.git/blob - Sub-Op-Test/Test.xs
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/Sub-Op.git] / 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);