]> git.vpit.fr Git - perl/modules/Sub-Op.git/blob - Test.xs
b3179698622f1592fcfe6c1ba5562ceca965bdc6
[perl/modules/Sub-Op.git] / 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);