BeginLift.xs

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