[p5sagit/Devel-BeginLift.git] / BeginLift.xs

#define PERL_CORE
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <stdio.h>
#include <string.h>

/* lifted from op.c */

#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))

/* pointer to old PL_check entersub entry to be populated in init */

STATIC OP *(*dbl_old_ck_entersub)(pTHX_ OP *op);

/* replacement PL_check entersub entry */

STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
  OP *kid;
  OP *last;
  OP *curop;
  HV *stash;
  I32 type = o->op_type;
  SV *sv;
  SV** stack_save;
  HV* to_lift;
  SV** to_lift_pack_ref;
  HV* to_lift_pack_hash;
  SV** to_lift_flag_ref;

  o = dbl_old_ck_entersub(aTHX_ o); /* let the original do its job */

  kid = cUNOPo->op_first;

  if (kid->op_type != OP_NULL) /* pushmark for method call ... */
    return o;

  last = kLISTOP->op_last;

  if (last->op_type != OP_NULL) /* not what we expected */
    return o;

  kid = cUNOPx(last)->op_first;

  if (kid->op_type != OP_GV) /* not a GV so ignore */
    return o;

  stash = GvSTASH(kGVOP_gv);

  /* printf("Calling GV %s -> %s\n",
    HvNAME(stash), GvNAME(kGVOP_gv)); */

  to_lift = get_hv("Devel::BeginLift::lift", FALSE);

  if (!to_lift)
    return o;

  to_lift_pack_ref = hv_fetch(to_lift, HvNAME(stash), strlen(HvNAME(stash)),
                               FALSE);

  if (!to_lift_pack_ref || !SvROK(*to_lift_pack_ref))
    return o; /* not a hashref */

  to_lift_pack_hash = (HV*) SvRV(*to_lift_pack_ref);

  to_lift_flag_ref = hv_fetch(to_lift_pack_hash, GvNAME(kGVOP_gv),
                                strlen(GvNAME(kGVOP_gv)), FALSE);

  if (!to_lift_flag_ref || !SvTRUE(*to_lift_flag_ref))
    return o;

  /* shamelessly lifted from fold_constants in op.c */

  stack_save = PL_stack_sp;
  curop = LINKLIST(o);
  o->op_next = 0;
  PL_op = curop;
  CALLRUNOPS(aTHX);

  if (PL_stack_sp > stack_save) { /* sub returned something */
    sv = *(PL_stack_sp--);
    if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
      pad_swipe(o->op_targ,  FALSE);
    else if (SvTEMP(sv)) {      /* grab mortal temp? */
      (void)SvREFCNT_inc(sv);
      SvTEMP_off(sv);
    }
    op_free(o);
    if (type == OP_RV2GV)
      return newGVOP(OP_GV, 0, (GV*)sv);
    return newSVOP(OP_CONST, 0, sv);
  } else {
    /* this bit not lifted, handles the 'sub doesn't return stuff' case
       which fold_constants can ignore */
    op_free(o);
    return newOP(OP_NULL, 0);
  }
}

static int initialized = 0;

MODULE = Devel::BeginLift  PACKAGE = Devel::BeginLift

PROTOTYPES: DISABLE

void
setup()
  CODE:
  if (!initialized++) {
    dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
    PL_check[OP_ENTERSUB] = dbl_ck_entersub;
  }

void
teardown()
  CODE:
  /* ensure we only uninit when number of teardown calls matches 
     number of setup calls */
  if (initialized && !--initialized) {
    PL_check[OP_ENTERSUB] = dbl_old_ck_entersub;
  }
Commit	Line	Data
c0f47301	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	}