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