2 #define PERL_NO_GET_CONTEXT
9 #include "hook_op_check_entersubforcv.h"
11 /* lifted from op.c */
13 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
16 # define linklist(o) THX_linklist(aTHX_ o)
17 STATIC OP *THX_linklist(pTHX_ OP *o) {
21 first = cUNOPo->op_first;
24 o->op_next = LINKLIST(first);
27 if (kid->op_sibling) {
28 kid->op_next = LINKLIST(kid->op_sibling);
29 kid = kid->op_sibling;
40 #endif /* !linklist */
42 STATIC OP *lift_cb(pTHX_ OP *o, CV *cv, void *user_data) {
46 OP *curop, *kid, *saved_next;
47 I32 type = o->op_type;
49 /* shamelessly lifted from fold_constants in op.c */
55 if (0) { /* call as macro */
58 /* this means the argument pushing ops are not executed, only the GV to
59 * resolve the call is, and B::OP objects will be made of all the opcodes
61 PUSHMARK(SP); /* push a mark for the arguments */
63 /* push an arg for every sibling op */
64 for ( arg = curop->op_sibling; arg->op_sibling; arg = arg->op_sibling ) {
65 XPUSHs(sv_bless(newRV_inc(newSViv(PTR2IV(arg))), gv_stashpv("B::LISTOP", 0)));
68 /* find the last non null before the lifted entersub */
69 for ( kid = curop; kid->op_next != o; kid = kid->op_next ) {
70 if ( kid->op_type == OP_GV )
74 PL_op = gv; /* make the call to our sub without evaluating the arg ops */
79 /* stop right after the call */
80 saved_next = o->op_next;
88 if (SP > stack_save) { /* sub returned something */
90 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
91 pad_swipe(o->op_targ, FALSE);
92 else if (SvTEMP(sv)) { /* grab mortal temp? */
93 (void)SvREFCNT_inc(sv);
97 if (SvROK(sv) && sv_derived_from(sv, "B::OP")) {
98 OP *new = INT2PTR(OP *,SvIV((SV *)SvRV(sv)));
99 new->op_sibling = NULL;
101 /* FIXME this is bullshit */
102 if ( (PL_opargs[new->op_type] & OA_CLASS_MASK) != OA_SVOP ) {
103 new->op_next = saved_next;
111 if (type == OP_RV2GV)
112 return newGVOP(OP_GV, 0, (GV*)sv);
114 if (SvTYPE(sv) == SVt_NULL) {
116 return newOP(OP_NULL, 0);
119 return newSVOP(OP_CONST, 0, sv);
121 /* this bit not lifted, handles the 'sub doesn't return stuff' case
122 which fold_constants can ignore */
124 return newOP(OP_NULL, 0);
128 MODULE = Devel::BeginLift PACKAGE = Devel::BeginLift
133 setup_for_cv (class, CV *cv)
135 RETVAL = (UV)hook_op_check_entersubforcv (cv, lift_cb, NULL);
140 teardown_for_cv (class, UV id)
142 hook_op_check_entersubforcv_remove ((hook_op_check_id)id);