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 PADOFFSET sols_find_sv_in_curpad(pTHX_ SV *sv) {
  15 #define sols_find_sv_in_curpad(S) sols_find_sv_in_curpad(aTHX_ (S))
  16  I32 ix;
  17  AV  *padlist = CvPADLIST(PL_compcv);
  18  AV  *comppad = (AV *) AvARRAY(padlist)[1];
  19  SV **curpad  = AvARRAY(comppad);
  20
  21  for (ix = AvFILLp(comppad); ix > 0; --ix) {
  22   if (curpad[ix] == sv)
  23    return ix;
  24  }
  25
  26  return NOT_IN_PAD;
  27 }
  28
  29 STATIC OP *sols_check(pTHX_ OP *o, void *ud_) {
  30  OP *gvop, *last_arg, *rv2cv;
  31  SV *cv = ud_;
  32  GV *gv;
  33
  34  gvop = sub_op_study(o, &last_arg, &rv2cv);
  35
  36  if (CvANON(cv)) {
  37   OP *anon;
  38
  39   CvDEPTH(CvOUTSIDE(cv))++;
  40   anon = newSVOP(OP_ANONCODE, 0, (SV *) Perl_cv_clone(aTHX_ (CV *) cv));
  41   CvDEPTH(CvOUTSIDE(cv))--;
  42
  43   last_arg->op_sibling = newUNOP(OP_REFGEN, 0, anon);
  44
  45   op_free(rv2cv);
  46  } else {
  47   SV *gv = (SV *) CvGV(cv);
  48
  49 #ifdef USE_ITHREADS
  50   PAD_SVl(cPADOPx(gvop)->op_padix) = gv;
  51 #else
  52   cSVOPx(gvop)->op_sv              = gv;
  53 #endif
  54   SvREFCNT_inc(gv);
  55  }
  56
  57  return o;
  58 }
  59
  60 /* --- XS ------------------------------------------------------------------ */
  61
  62 MODULE = Sub::Op::LexicalSub      PACKAGE = Sub::Op::LexicalSub
  63
  64 PROTOTYPES: ENABLE
  65
  66 void
  67 _init(SV *name, SV *cb)
  68 PROTOTYPE: $$
  69 PREINIT:
  70  sub_op_config_t c;
  71 PPCODE:
  72  if (SvROK(cb)) {
  73   cb = SvRV(cb);
  74   if (SvTYPE(cb) >= SVt_PVCV) {
  75    sub_op_init(&c);
  76    c.name   = SvPV_const(name, c.namelen);
  77    if (SvPOK(cb)) { /* Sub is prototyped */
  78     c.proto = SvPV_const(cb, c.protolen);
  79    }
  80    c.check  = sols_check;
  81    c.ud     = SvREFCNT_inc(cb);
  82    sub_op_register(aTHX_ &c, 0);
  83   }
  84  }
  85  XSRETURN(0);