]> git.vpit.fr Git - perl/modules/Sub-Op.git/blob - t/Sub-Op-LexicalSub/LexicalSub.xs
Fix deparsing of sub deref
[perl/modules/Sub-Op.git] / t / Sub-Op-LexicalSub / LexicalSub.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::LexicalSub"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
11
12 #include "sub_op.h"
13
14 STATIC HV *sols_map = NULL;
15
16 STATIC OP *sols_check(pTHX_ OP *o, void *ud_) {
17  char buf[sizeof(void*)*2+1];
18  SV *cb = ud_;
19
20  (void) hv_store(sols_map, buf, sprintf(buf, "%"UVxf, PTR2UV(o)), cb, 0);
21
22  return o;
23 }
24
25 STATIC OP *sols_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(sols_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::LexicalSub      PACKAGE = Sub::Op::LexicalSub
61
62 PROTOTYPES: ENABLE
63
64 BOOT:
65 {
66  sols_map = newHV();
67 }
68
69 void
70 _init(SV *name, SV *cb)
71 PROTOTYPE: $$
72 PREINIT:
73  sub_op_config_t c;
74 PPCODE:
75  if (SvROK(cb)) {
76   cb = SvRV(cb);
77   if (SvTYPE(cb) >= SVt_PVCV) {
78    c.name  = SvPV_const(name, c.len);
79    c.check = sols_check;
80    c.ud    = SvREFCNT_inc(cb);
81    c.pp    = sols_pp;
82    sub_op_register(aTHX_ &c);
83   }
84  }
85  XSRETURN(0);