BeginLift.xs

   1 #define PERL_CORE
   2 #define PERL_NO_GET_CONTEXT
   3 #include "EXTERN.h"
   4 #include "perl.h"
   5 #include "XSUB.h"
   6 #include <stdio.h>
   7 #include <string.h>
   8
   9 /* lifted from op.c */
  10
  11 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
  12
  13 /* pointer to old PL_check entersub entry to be populated in init */
  14
  15 STATIC OP *(*dbl_old_ck_entersub)(pTHX_ OP *op);
  16
  17 /* replacement PL_check entersub entry */
  18
  19 STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
  20   OP *kid;
  21   OP *last;
  22   OP *curop;
  23   HV *stash;
  24   I32 type = o->op_type;
  25   SV *sv;
  26   SV** stack_save;
  27   HV* to_lift;
  28   SV** to_lift_pack_ref;
  29   HV* to_lift_pack_hash;
  30   SV** to_lift_flag_ref;
  31
  32   o = dbl_old_ck_entersub(aTHX_ o); /* let the original do its job */
  33
  34   kid = cUNOPo->op_first;
  35
  36   if (kid->op_type != OP_NULL) /* pushmark for method call ... */
  37     return o;
  38
  39   last = kLISTOP->op_last;
  40
  41   if (last->op_type != OP_NULL) /* not what we expected */
  42     return o;
  43
  44   kid = cUNOPx(last)->op_first;
  45
  46   if (kid->op_type != OP_GV) /* not a GV so ignore */
  47     return o;
  48
  49   stash = GvSTASH(kGVOP_gv);
  50
  51   /* printf("Calling GV %s -> %s\n",
  52     HvNAME(stash), GvNAME(kGVOP_gv)); */
  53
  54   to_lift = get_hv("Devel::BeginLift::lift", FALSE);
  55
  56   if (!to_lift)
  57     return o;
  58
  59   to_lift_pack_ref = hv_fetch(to_lift, HvNAME(stash), strlen(HvNAME(stash)),
  60                                FALSE);
  61
  62   if (!to_lift_pack_ref || !SvROK(*to_lift_pack_ref))
  63     return o; /* not a hashref */
  64
  65   to_lift_pack_hash = (HV*) SvRV(*to_lift_pack_ref);
  66
  67   to_lift_flag_ref = hv_fetch(to_lift_pack_hash, GvNAME(kGVOP_gv),
  68                                 strlen(GvNAME(kGVOP_gv)), FALSE);
  69
  70   if (!to_lift_flag_ref || !SvTRUE(*to_lift_flag_ref))
  71     return o;
  72
  73   /* shamelessly lifted from fold_constants in op.c */
  74
  75   stack_save = PL_stack_sp;
  76   curop = LINKLIST(o);
  77   o->op_next = 0;
  78   PL_op = curop;
  79   CALLRUNOPS(aTHX);
  80
  81   if (PL_stack_sp > stack_save) { /* sub returned something */
  82     sv = *(PL_stack_sp--);
  83     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
  84       pad_swipe(o->op_targ,  FALSE);
  85     else if (SvTEMP(sv)) {      /* grab mortal temp? */
  86       (void)SvREFCNT_inc(sv);
  87       SvTEMP_off(sv);
  88     }
  89     op_free(o);
  90     if (type == OP_RV2GV)
  91       return newGVOP(OP_GV, 0, (GV*)sv);
  92     return newSVOP(OP_CONST, 0, sv);
  93   } else {
  94     /* this bit not lifted, handles the 'sub doesn't return stuff' case
  95        which fold_constants can ignore */
  96     op_free(o);
  97     return newOP(OP_NULL, 0);
  98   }
  99 }
 100
 101 static int initialized = 0;
 102
 103 MODULE = Devel::BeginLift  PACKAGE = Devel::BeginLift
 104
 105 PROTOTYPES: DISABLE
 106
 107 void
 108 setup()
 109   CODE:
 110   if (!initialized++) {
 111     dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
 112     PL_check[OP_ENTERSUB] = dbl_ck_entersub;
 113   }
 114
 115 void
 116 teardown()
 117   CODE:
 118   /* ensure we only uninit when number of teardown calls matches
 119      number of setup calls */
 120   if (initialized && !--initialized) {
 121     PL_check[OP_ENTERSUB] = dbl_old_ck_entersub;
 122   }