lib/Devel/BeginLift.pm

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