line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
2
|
|
|
|
|
|
|
#include "EXTERN.h" |
3
|
|
|
|
|
|
|
#include "perl.h" |
4
|
|
|
|
|
|
|
#include "XSUB.h" |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
#include "ppport.h" |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
#include "const-c.inc" |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) |
11
|
|
|
|
|
|
|
#define PERL_DECIMAL_VERSION PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) |
12
|
|
|
|
|
|
|
#define PERL_VERSION_GE(r,v,s) (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
struct block_symbol_t { |
15
|
|
|
|
|
|
|
CV * cv; |
16
|
|
|
|
|
|
|
SV * symbol_SV; |
17
|
|
|
|
|
|
|
}; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
static Perl_ppaddr_t return_ppaddr; |
20
|
|
|
|
|
|
|
static struct block_symbol_t * block_symbols; |
21
|
|
|
|
|
|
|
static int block_symbols_capacity, block_symbols_n; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
static SV * regex_match_sv; |
24
|
|
|
|
|
|
|
|
25
|
5
|
|
|
|
|
|
static OP * my_pp_deep_ret(pTHX){ |
26
|
5
|
|
|
|
|
|
dSP; POPs; |
27
|
|
|
|
|
|
|
|
28
|
5
|
50
|
|
|
|
|
IV depth = SvIV(PL_stack_base[TOPMARK+1]); |
29
|
|
|
|
|
|
|
|
30
|
20
|
100
|
|
|
|
|
for(SV ** p = PL_stack_base+TOPMARK+1; p
|
31
|
15
|
|
|
|
|
|
*p = *(p+1); |
32
|
5
|
|
|
|
|
|
POPs; |
33
|
|
|
|
|
|
|
|
34
|
5
|
100
|
|
|
|
|
if( depth <= 0 ) |
35
|
1
|
|
|
|
|
|
RETURN; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
OP * next_op; |
38
|
14
|
100
|
|
|
|
|
while( depth-- ) |
39
|
10
|
|
|
|
|
|
next_op = return_ppaddr(aTHX); |
40
|
4
|
|
|
|
|
|
RETURNOP(next_op); |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
8
|
|
|
|
|
|
static OP * my_pp_sym_ret(pTHX){ |
44
|
8
|
|
|
|
|
|
dSP; POPs; |
45
|
|
|
|
|
|
|
|
46
|
8
|
|
|
|
|
|
SV * symbol_SV = PL_stack_base[TOPMARK+1]; |
47
|
|
|
|
|
|
|
|
48
|
32
|
100
|
|
|
|
|
for(SV ** p = PL_stack_base+TOPMARK+1; p
|
49
|
24
|
|
|
|
|
|
*p = *(p+1); |
50
|
8
|
|
|
|
|
|
POPs; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
while(TRUE){ |
53
|
56
|
50
|
|
|
|
|
for(PERL_CONTEXT * cx = &cxstack[cxstack_ix]; cx>=cxstack; --cx){ |
54
|
56
|
|
|
|
|
|
switch( CxTYPE(cx) ){ |
55
|
|
|
|
|
|
|
default: |
56
|
0
|
|
|
|
|
|
continue; |
57
|
|
|
|
|
|
|
case CXt_SUB: |
58
|
|
|
|
|
|
|
#if PERL_VERSION_GE(5,18,0) |
59
|
56
|
50
|
|
|
|
|
if( cx->cx_type & CXp_SUB_RE_FAKE ) |
60
|
0
|
|
|
|
|
|
continue; |
61
|
|
|
|
|
|
|
#endif |
62
|
193
|
100
|
|
|
|
|
for(struct block_symbol_t *p = block_symbols+block_symbols_n-1; p>=block_symbols; --p) |
63
|
145
|
100
|
|
|
|
|
if( p->cv == cx->blk_sub.cv ){ |
64
|
24
|
100
|
|
|
|
|
if( !SvOK(p->symbol_SV) ) |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
65
|
4
|
|
|
|
|
|
RETURNOP(return_ppaddr(aTHX)); |
66
|
|
|
|
|
|
|
#if PERL_VERSION_GE(5,10,0) |
67
|
20
|
100
|
|
|
|
|
if( SvRXOK(p->symbol_SV) ){ |
68
|
7
|
50
|
|
|
|
|
PUSHMARK(SP); |
69
|
7
|
50
|
|
|
|
|
EXTEND(SP, 2); |
70
|
7
|
|
|
|
|
|
PUSHs(p->symbol_SV); |
71
|
7
|
|
|
|
|
|
PUSHs(symbol_SV); |
72
|
7
|
|
|
|
|
|
PUTBACK; |
73
|
7
|
|
|
|
|
|
call_sv(regex_match_sv, G_SCALAR); |
74
|
7
|
|
|
|
|
|
SPAGAIN; |
75
|
7
|
50
|
|
|
|
|
IV match_res = POPi; |
76
|
7
|
|
|
|
|
|
PUTBACK; |
77
|
|
|
|
|
|
|
|
78
|
7
|
100
|
|
|
|
|
if( match_res ) |
79
|
7
|
|
|
|
|
|
RETURNOP(return_ppaddr(aTHX)); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
else |
82
|
|
|
|
|
|
|
#endif |
83
|
13
|
100
|
|
|
|
|
if( sv_cmp(p->symbol_SV, symbol_SV)==0 ) |
84
|
2
|
|
|
|
|
|
RETURNOP(return_ppaddr(aTHX)); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
case CXt_EVAL: |
87
|
|
|
|
|
|
|
case CXt_FORMAT: |
88
|
48
|
|
|
|
|
|
goto DO_RETURN; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
DO_RETURN: |
92
|
48
|
|
|
|
|
|
return_ppaddr(aTHX); |
93
|
48
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
1
|
|
|
|
|
|
static OP * deep_ret_check(pTHX_ OP * o, GV * namegv, SV * ckobj){ |
97
|
1
|
|
|
|
|
|
o->op_ppaddr = my_pp_deep_ret; |
98
|
1
|
|
|
|
|
|
return o; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
1
|
|
|
|
|
|
static OP * sym_ret_check(pTHX_ OP * o, GV * namegv, SV * ckobj){ |
102
|
1
|
|
|
|
|
|
o->op_ppaddr = my_pp_sym_ret; |
103
|
1
|
|
|
|
|
|
return o; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
32
|
|
|
|
|
|
static int guard_free(pTHX_ SV * guard_SV, MAGIC * mg){ |
107
|
32
|
50
|
|
|
|
|
for(struct block_symbol_t * p=block_symbols+block_symbols_n-1; p>=block_symbols; --p) |
108
|
32
|
50
|
|
|
|
|
if( (IV)p->cv == (IV)mg->mg_ptr ){ |
109
|
32
|
|
|
|
|
|
--block_symbols_n; |
110
|
32
|
|
|
|
|
|
*p = block_symbols[block_symbols_n]; |
111
|
32
|
|
|
|
|
|
break; |
112
|
|
|
|
|
|
|
} |
113
|
32
|
|
|
|
|
|
return 0; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
static MGVTBL guard_vtbl = { |
117
|
|
|
|
|
|
|
0, 0, 0, 0, |
118
|
|
|
|
|
|
|
guard_free |
119
|
|
|
|
|
|
|
}; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
#if !PERL_VERSION_GE(5,14,0) |
122
|
|
|
|
|
|
|
static CV* my_deep_ret_cv; |
123
|
|
|
|
|
|
|
static CV* my_sym_ret_cv; |
124
|
|
|
|
|
|
|
static OP* (*orig_entersub_check)(pTHX_ OP*); |
125
|
|
|
|
|
|
|
static OP* my_entersub_check(pTHX_ OP* o){ |
126
|
|
|
|
|
|
|
CV *cv = NULL; |
127
|
|
|
|
|
|
|
OP *cvop = OpSIBLING(((OpSIBLING(cUNOPo->op_first)) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first); |
128
|
|
|
|
|
|
|
while( OpSIBLING(cvop) ) |
129
|
|
|
|
|
|
|
cvop = OpSIBLING(cvop); |
130
|
|
|
|
|
|
|
if( cvop->op_type == OP_RV2CV && !(o->op_private & OPpENTERSUB_AMPER) ){ |
131
|
|
|
|
|
|
|
SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first; |
132
|
|
|
|
|
|
|
switch (tmpop->op_type) { |
133
|
|
|
|
|
|
|
case OP_GV: { |
134
|
|
|
|
|
|
|
GV *gv = cGVOPx_gv(tmpop); |
135
|
|
|
|
|
|
|
cv = GvCVu(gv); |
136
|
|
|
|
|
|
|
if (!cv) |
137
|
|
|
|
|
|
|
tmpop->op_private |= OPpEARLY_CV; |
138
|
|
|
|
|
|
|
} break; |
139
|
|
|
|
|
|
|
case OP_CONST: { |
140
|
|
|
|
|
|
|
SV *sv = cSVOPx_sv(tmpop); |
141
|
|
|
|
|
|
|
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) |
142
|
|
|
|
|
|
|
cv = (CV*)SvRV(sv); |
143
|
|
|
|
|
|
|
} break; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
if( cv==my_deep_ret_cv ) |
146
|
|
|
|
|
|
|
o->op_ppaddr = my_pp_deep_ret; |
147
|
|
|
|
|
|
|
if( cv==my_sym_ret_cv ) |
148
|
|
|
|
|
|
|
o->op_ppaddr = my_pp_sym_ret; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
return orig_entersub_check(aTHX_ o); |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
#endif |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
MODULE = Return::Deep PACKAGE = Return::Deep |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
INCLUDE: const-xs.inc |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
void add_bound(SV * act_SV, SV * symbol_SV) |
159
|
|
|
|
|
|
|
PPCODE: |
160
|
32
|
50
|
|
|
|
|
if( !(SvOK(act_SV) && SvROK(act_SV) && SvTYPE(SvRV(act_SV))==SVt_PVCV) ) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
161
|
0
|
|
|
|
|
|
croak("there should be a code block"); |
162
|
|
|
|
|
|
|
|
163
|
32
|
|
|
|
|
|
CV * act_CV = (CV*) SvRV(act_SV); |
164
|
32
|
|
|
|
|
|
SV * guard_SV = newSV(0); |
165
|
|
|
|
|
|
|
|
166
|
32
|
|
|
|
|
|
sv_magicext(guard_SV, NULL, PERL_MAGIC_ext, &guard_vtbl, (char*) act_CV, 0); |
167
|
|
|
|
|
|
|
|
168
|
32
|
50
|
|
|
|
|
if( block_symbols_n >= block_symbols_capacity ){ |
169
|
0
|
|
|
|
|
|
block_symbols_capacity *= 2; |
170
|
0
|
0
|
|
|
|
|
Renew(block_symbols, block_symbols_capacity, struct block_symbol_t); |
171
|
|
|
|
|
|
|
} |
172
|
32
|
|
|
|
|
|
block_symbols[block_symbols_n].cv = act_CV; |
173
|
32
|
|
|
|
|
|
block_symbols[block_symbols_n].symbol_SV = symbol_SV; |
174
|
32
|
|
|
|
|
|
++block_symbols_n; |
175
|
|
|
|
|
|
|
|
176
|
32
|
|
|
|
|
|
PUSHs(sv_2mortal(newRV_noinc(guard_SV))); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
BOOT: |
179
|
1
|
|
|
|
|
|
block_symbols_capacity = 8; |
180
|
1
|
|
|
|
|
|
block_symbols_n = 0; |
181
|
1
|
50
|
|
|
|
|
Newx(block_symbols, block_symbols_capacity, struct block_symbol_t); |
182
|
|
|
|
|
|
|
|
183
|
1
|
|
|
|
|
|
regex_match_sv = newRV_inc((SV*)get_cv("Return::Deep::regex_match", FALSE)); |
184
|
|
|
|
|
|
|
|
185
|
1
|
|
|
|
|
|
return_ppaddr = PL_ppaddr[OP_RETURN]; |
186
|
|
|
|
|
|
|
#if PERL_VERSION_GE(5,14,0) |
187
|
1
|
|
|
|
|
|
cv_set_call_checker(get_cv("Return::Deep::deep_ret", TRUE), deep_ret_check, &PL_sv_undef); |
188
|
1
|
|
|
|
|
|
cv_set_call_checker(get_cv("Return::Deep::sym_ret", TRUE), sym_ret_check, &PL_sv_undef); |
189
|
|
|
|
|
|
|
#else |
190
|
|
|
|
|
|
|
my_deep_ret_cv = get_cv("Return::Deep::deep_ret", TRUE); |
191
|
|
|
|
|
|
|
my_sym_ret_cv = get_cv("Return::Deep::sym_ret", TRUE); |
192
|
|
|
|
|
|
|
orig_entersub_check = PL_check[OP_ENTERSUB]; |
193
|
|
|
|
|
|
|
PL_check[OP_ENTERSUB] = my_entersub_check; |
194
|
|
|
|
|
|
|
#endif |