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  SV *cb;
  28  int i, items;
  29
  30  {
  31   char buf[sizeof(void*)*2+1];
  32   SV **svp;
  33   svp = hv_fetch(sols_map, buf, sprintf(buf, "%"UVxf, PTR2UV(PL_op)), 0);
  34   if (!svp)
  35    RETURN;
  36   cb = *svp;
  37  }
  38
  39  XPUSHs(cb);
  40  PUTBACK;
  41
  42  return CALL_FPTR(PL_ppaddr[OP_ENTERSUB])(aTHX);
  43 }
  44
  45 /* --- XS ------------------------------------------------------------------ */
  46
  47 MODULE = Sub::Op::LexicalSub      PACKAGE = Sub::Op::LexicalSub
  48
  49 PROTOTYPES: ENABLE
  50
  51 BOOT:
  52 {
  53  sols_map = newHV();
  54 }
  55
  56 void
  57 _init(SV *name, SV *cb)
  58 PROTOTYPE: $$
  59 PREINIT:
  60  sub_op_config_t c;
  61 PPCODE:
  62  if (SvROK(cb)) {
  63   cb = SvRV(cb);
  64   if (SvTYPE(cb) >= SVt_PVCV) {
  65    sub_op_init(&c);
  66    c.name   = SvPV_const(name, c.namelen);
  67    if (SvPOK(cb)) { /* Sub is prototyped */
  68     c.proto = SvPV_const(cb, c.protolen);
  69    }
  70    c.check  = sols_check;
  71    c.ud     = SvREFCNT_inc(cb);
  72    c.pp     = sols_pp;
  73    sub_op_register(aTHX_ &c, 0);
  74   }
  75  }
  76  XSRETURN(0);