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 | |
5df2f925 |
15 | #ifndef linklist |
16 | # define linklist(o) THX_linklist(aTHX_ o) |
17 | STATIC OP *THX_linklist(pTHX_ OP *o) { |
18 | OP *first; |
19 | if(o->op_next) |
20 | return o->op_next; |
21 | first = cUNOPo->op_first; |
22 | if (first) { |
23 | OP *kid; |
24 | o->op_next = LINKLIST(first); |
25 | kid = first; |
26 | for (;;) { |
27 | if (kid->op_sibling) { |
28 | kid->op_next = LINKLIST(kid->op_sibling); |
29 | kid = kid->op_sibling; |
30 | } else { |
31 | kid->op_next = o; |
32 | break; |
33 | } |
34 | } |
35 | } else { |
36 | o->op_next = o; |
37 | } |
38 | return o->op_next; |
39 | } |
40 | #endif /* !linklist */ |
41 | |
5e5bdebb |
42 | STATIC OP *lift_cb(pTHX_ OP *o, CV *cv, void *user_data) { |
62b5f5ed |
43 | dSP; |
c0f47301 |
44 | SV *sv; |
5e5bdebb |
45 | SV **stack_save; |
46 | OP *curop, *kid, *saved_next; |
47 | I32 type = o->op_type; |
c0f47301 |
48 | |
49 | /* shamelessly lifted from fold_constants in op.c */ |
50 | |
62b5f5ed |
51 | stack_save = SP; |
52 | |
c0f47301 |
53 | curop = LINKLIST(o); |
62b5f5ed |
54 | |
55 | if (0) { /* call as macro */ |
56 | OP *arg; |
57 | OP *gv; |
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 |
60 | * */ |
61 | PUSHMARK(SP); /* push a mark for the arguments */ |
62 | |
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))); |
66 | } |
67 | |
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 ) |
71 | gv = kid; |
72 | } |
73 | |
74 | PL_op = gv; /* make the call to our sub without evaluating the arg ops */ |
75 | } else { |
76 | PL_op = curop; |
77 | } |
78 | |
79 | /* stop right after the call */ |
80 | saved_next = o->op_next; |
81 | o->op_next = NULL; |
82 | |
83 | PUTBACK; |
84 | SAVETMPS; |
c0f47301 |
85 | CALLRUNOPS(aTHX); |
62b5f5ed |
86 | SPAGAIN; |
c0f47301 |
87 | |
62b5f5ed |
88 | if (SP > stack_save) { /* sub returned something */ |
89 | sv = POPs; |
c0f47301 |
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); |
94 | SvTEMP_off(sv); |
95 | } |
62b5f5ed |
96 | |
97 | if (SvROK(sv) && sv_derived_from(sv, "B::OP")) { |
98 | OP *new = INT2PTR(OP *,SvIV((SV *)SvRV(sv))); |
99 | new->op_sibling = NULL; |
100 | |
101 | /* FIXME this is bullshit */ |
102 | if ( (PL_opargs[new->op_type] & OA_CLASS_MASK) != OA_SVOP ) { |
103 | new->op_next = saved_next; |
104 | } else { |
105 | new->op_next = new; |
106 | } |
107 | |
108 | return new; |
109 | } |
110 | |
c0f47301 |
111 | if (type == OP_RV2GV) |
112 | return newGVOP(OP_GV, 0, (GV*)sv); |
4d07fd95 |
113 | |
bd42c00a |
114 | if (SvTYPE(sv) == SVt_NULL) { |
115 | op_free(o); |
116 | return newOP(OP_NULL, 0); |
117 | } |
118 | |
c0f47301 |
119 | return newSVOP(OP_CONST, 0, sv); |
120 | } else { |
121 | /* this bit not lifted, handles the 'sub doesn't return stuff' case |
122 | which fold_constants can ignore */ |
123 | op_free(o); |
124 | return newOP(OP_NULL, 0); |
125 | } |
126 | } |
127 | |
c0f47301 |
128 | MODULE = Devel::BeginLift PACKAGE = Devel::BeginLift |
129 | |
130 | PROTOTYPES: DISABLE |
131 | |
5e5bdebb |
132 | UV |
eeee00df |
133 | setup_for_cv (class, CV *cv) |
c0f47301 |
134 | CODE: |
5e5bdebb |
135 | RETVAL = (UV)hook_op_check_entersubforcv (cv, lift_cb, NULL); |
136 | OUTPUT: |
137 | RETVAL |
c0f47301 |
138 | |
139 | void |
eeee00df |
140 | teardown_for_cv (class, UV id) |
c0f47301 |
141 | CODE: |
5e5bdebb |
142 | hook_op_check_entersubforcv_remove ((hook_op_check_id)id); |