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 | |
5e5bdebb |
9 | #include "hook_op_check_entersubforcv.h" |
10 | |
c0f47301 |
11 | /* lifted from op.c */ |
12 | |
13 | #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) |
14 | |
5e5bdebb |
15 | STATIC OP *lift_cb(pTHX_ OP *o, CV *cv, void *user_data) { |
62b5f5ed |
16 | dSP; |
c0f47301 |
17 | SV *sv; |
5e5bdebb |
18 | SV **stack_save; |
19 | OP *curop, *kid, *saved_next; |
20 | I32 type = o->op_type; |
c0f47301 |
21 | |
22 | /* shamelessly lifted from fold_constants in op.c */ |
23 | |
62b5f5ed |
24 | stack_save = SP; |
25 | |
c0f47301 |
26 | curop = LINKLIST(o); |
62b5f5ed |
27 | |
28 | if (0) { /* call as macro */ |
29 | OP *arg; |
30 | OP *gv; |
31 | /* this means the argument pushing ops are not executed, only the GV to |
32 | * resolve the call is, and B::OP objects will be made of all the opcodes |
33 | * */ |
34 | PUSHMARK(SP); /* push a mark for the arguments */ |
35 | |
36 | /* push an arg for every sibling op */ |
37 | for ( arg = curop->op_sibling; arg->op_sibling; arg = arg->op_sibling ) { |
38 | XPUSHs(sv_bless(newRV_inc(newSViv(PTR2IV(arg))), gv_stashpv("B::LISTOP", 0))); |
39 | } |
40 | |
41 | /* find the last non null before the lifted entersub */ |
42 | for ( kid = curop; kid->op_next != o; kid = kid->op_next ) { |
43 | if ( kid->op_type == OP_GV ) |
44 | gv = kid; |
45 | } |
46 | |
47 | PL_op = gv; /* make the call to our sub without evaluating the arg ops */ |
48 | } else { |
49 | PL_op = curop; |
50 | } |
51 | |
52 | /* stop right after the call */ |
53 | saved_next = o->op_next; |
54 | o->op_next = NULL; |
55 | |
56 | PUTBACK; |
57 | SAVETMPS; |
c0f47301 |
58 | CALLRUNOPS(aTHX); |
62b5f5ed |
59 | SPAGAIN; |
c0f47301 |
60 | |
62b5f5ed |
61 | if (SP > stack_save) { /* sub returned something */ |
62 | sv = POPs; |
c0f47301 |
63 | if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ |
64 | pad_swipe(o->op_targ, FALSE); |
65 | else if (SvTEMP(sv)) { /* grab mortal temp? */ |
66 | (void)SvREFCNT_inc(sv); |
67 | SvTEMP_off(sv); |
68 | } |
62b5f5ed |
69 | |
70 | if (SvROK(sv) && sv_derived_from(sv, "B::OP")) { |
71 | OP *new = INT2PTR(OP *,SvIV((SV *)SvRV(sv))); |
72 | new->op_sibling = NULL; |
73 | |
74 | /* FIXME this is bullshit */ |
75 | if ( (PL_opargs[new->op_type] & OA_CLASS_MASK) != OA_SVOP ) { |
76 | new->op_next = saved_next; |
77 | } else { |
78 | new->op_next = new; |
79 | } |
80 | |
81 | return new; |
82 | } |
83 | |
c0f47301 |
84 | if (type == OP_RV2GV) |
85 | return newGVOP(OP_GV, 0, (GV*)sv); |
4d07fd95 |
86 | |
c0f47301 |
87 | return newSVOP(OP_CONST, 0, sv); |
88 | } else { |
89 | /* this bit not lifted, handles the 'sub doesn't return stuff' case |
90 | which fold_constants can ignore */ |
91 | op_free(o); |
92 | return newOP(OP_NULL, 0); |
93 | } |
94 | } |
95 | |
c0f47301 |
96 | MODULE = Devel::BeginLift PACKAGE = Devel::BeginLift |
97 | |
98 | PROTOTYPES: DISABLE |
99 | |
5e5bdebb |
100 | UV |
101 | _setup (CV *cv) |
c0f47301 |
102 | CODE: |
5e5bdebb |
103 | RETVAL = (UV)hook_op_check_entersubforcv (cv, lift_cb, NULL); |
104 | OUTPUT: |
105 | RETVAL |
c0f47301 |
106 | |
107 | void |
5e5bdebb |
108 | _teardown (UV id) |
c0f47301 |
109 | CODE: |
5e5bdebb |
110 | hook_op_check_entersubforcv_remove ((hook_op_check_id)id); |