line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
/* You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
* or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
* |
4
|
|
|
|
|
|
|
* (C) Paul Evans, 2016-2021 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
*/ |
6
|
|
|
|
|
|
|
#include "EXTERN.h" |
7
|
|
|
|
|
|
|
#include "perl.h" |
8
|
|
|
|
|
|
|
#include "XSUB.h" |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
#include "XSParseKeyword.h" |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
#include "perl-backcompat.c.inc" |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5,32,0) |
15
|
|
|
|
|
|
|
# define HAVE_OP_ISA |
16
|
|
|
|
|
|
|
#endif |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5,26,0) |
19
|
|
|
|
|
|
|
# define HAVE_OP_SIBPARENT |
20
|
|
|
|
|
|
|
#endif |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5,19,4) |
23
|
|
|
|
|
|
|
typedef SSize_t array_ix_t; |
24
|
|
|
|
|
|
|
#else /* <5.19.4 */ |
25
|
|
|
|
|
|
|
typedef I32 array_ix_t; |
26
|
|
|
|
|
|
|
#endif /* <5.19.4 */ |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#include "perl-additions.c.inc" |
29
|
|
|
|
|
|
|
#include "optree-additions.c.inc" |
30
|
|
|
|
|
|
|
#include "op_sibling_splice.c.inc" |
31
|
|
|
|
|
|
|
#include "newOP_CUSTOM.c.inc" |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
static OP *pp_entertrycatch(pTHX); |
34
|
|
|
|
|
|
|
static OP *pp_catch(pTHX); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
/* |
37
|
|
|
|
|
|
|
* A modified version of pp_return for returning from inside a try block. |
38
|
|
|
|
|
|
|
* To do this, we unwind the context stack to just past the CXt_EVAL and then |
39
|
|
|
|
|
|
|
* chain to the regular OP_RETURN func |
40
|
|
|
|
|
|
|
*/ |
41
|
7
|
|
|
|
|
|
static OP *pp_returnintry(pTHX) |
42
|
|
|
|
|
|
|
{ |
43
|
|
|
|
|
|
|
I32 cxix; |
44
|
|
|
|
|
|
|
|
45
|
23
|
50
|
|
|
|
|
for (cxix = cxstack_ix; cxix; cxix--) { |
46
|
23
|
100
|
|
|
|
|
if(CxTYPE(&cxstack[cxix]) == CXt_SUB) |
47
|
|
|
|
|
|
|
break; |
48
|
|
|
|
|
|
|
|
49
|
17
|
100
|
|
|
|
|
if(CxTYPE(&cxstack[cxix]) == CXt_EVAL && CxTRYBLOCK(&cxstack[cxix])) { |
50
|
|
|
|
|
|
|
/* If this CXt_EVAL frame came from our own ENTERTRYCATCH, then the |
51
|
|
|
|
|
|
|
* retop should point at an OP_CUSTOM and its first grand-child will be |
52
|
|
|
|
|
|
|
* our custom modified ENTERTRY. We can skip over it and continue in |
53
|
|
|
|
|
|
|
* this case. |
54
|
|
|
|
|
|
|
*/ |
55
|
9
|
|
|
|
|
|
OP *retop = cxstack[cxix].blk_eval.retop; |
56
|
|
|
|
|
|
|
OP *leave, *enter; |
57
|
9
|
100
|
|
|
|
|
if(retop->op_type == OP_CUSTOM && retop->op_ppaddr == &pp_catch && |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
58
|
8
|
50
|
|
|
|
|
(leave = cLOGOPx(retop)->op_first) && leave->op_type == OP_LEAVETRY && |
|
|
50
|
|
|
|
|
|
59
|
8
|
50
|
|
|
|
|
(enter = cLOGOPx(leave)->op_first) && enter->op_type == OP_ENTERTRY && |
|
|
50
|
|
|
|
|
|
60
|
8
|
|
|
|
|
|
enter->op_ppaddr == &pp_entertrycatch) { |
61
|
8
|
|
|
|
|
|
continue; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
/* We have to stop at any other kind of CXt_EVAL */ |
64
|
|
|
|
|
|
|
break; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
} |
67
|
7
|
50
|
|
|
|
|
if(!cxix) |
68
|
0
|
|
|
|
|
|
croak("Unable to find an CXt_SUB to pop back to"); |
69
|
|
|
|
|
|
|
|
70
|
7
|
|
|
|
|
|
I32 gimme = cxstack[cxix].blk_gimme; |
71
|
|
|
|
|
|
|
SV *retval; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
/* chunks of this code inspired by |
74
|
|
|
|
|
|
|
* ZEFRAM/Scope-Escape-0.005/lib/Scope/Escape.xs |
75
|
|
|
|
|
|
|
*/ |
76
|
7
|
|
|
|
|
|
switch(gimme) { |
77
|
|
|
|
|
|
|
case G_VOID: |
78
|
|
|
|
|
|
|
(void)POPMARK; |
79
|
|
|
|
|
|
|
break; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
case G_SCALAR: { |
82
|
5
|
|
|
|
|
|
dSP; |
83
|
10
|
|
|
|
|
|
dMARK; |
84
|
5
|
50
|
|
|
|
|
retval = (MARK == SP) ? &PL_sv_undef : TOPs; |
85
|
|
|
|
|
|
|
SvREFCNT_inc(retval); |
86
|
5
|
|
|
|
|
|
sv_2mortal(retval); |
87
|
5
|
|
|
|
|
|
break; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
case G_LIST: { |
91
|
1
|
|
|
|
|
|
dSP; |
92
|
2
|
|
|
|
|
|
dMARK; |
93
|
1
|
|
|
|
|
|
SV **retvals = MARK+1; |
94
|
1
|
|
|
|
|
|
array_ix_t retcount = SP-MARK; |
95
|
|
|
|
|
|
|
array_ix_t i; |
96
|
1
|
|
|
|
|
|
AV *retav = newAV(); |
97
|
|
|
|
|
|
|
retval = (SV *)retav; |
98
|
1
|
|
|
|
|
|
sv_2mortal(retval); |
99
|
1
|
|
|
|
|
|
av_fill(retav, retcount-1); |
100
|
1
|
50
|
|
|
|
|
Copy(retvals, AvARRAY(retav), retcount, SV *); |
101
|
4
|
100
|
|
|
|
|
for(i = 0; i < retcount; i++) |
102
|
3
|
|
|
|
|
|
SvREFCNT_inc(retvals[i]); |
103
|
|
|
|
|
|
|
break; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
7
|
|
|
|
|
|
dounwind(cxix); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
/* Now put the value back */ |
110
|
7
|
|
|
|
|
|
switch(gimme) { |
111
|
|
|
|
|
|
|
case G_VOID: { |
112
|
1
|
|
|
|
|
|
dSP; |
113
|
1
|
50
|
|
|
|
|
PUSHMARK(SP); |
114
|
1
|
|
|
|
|
|
break; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
case G_SCALAR: { |
118
|
5
|
|
|
|
|
|
dSP; |
119
|
5
|
50
|
|
|
|
|
PUSHMARK(SP); |
120
|
5
|
50
|
|
|
|
|
XPUSHs(retval); |
121
|
5
|
|
|
|
|
|
PUTBACK; |
122
|
5
|
|
|
|
|
|
break; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
case G_LIST: { |
126
|
1
|
|
|
|
|
|
dSP; |
127
|
1
|
50
|
|
|
|
|
PUSHMARK(SP); |
128
|
|
|
|
|
|
|
AV *retav = (AV *)retval; |
129
|
1
|
|
|
|
|
|
array_ix_t retcount = av_len(retav) + 1; /* because av_len means top index */ |
130
|
1
|
50
|
|
|
|
|
EXTEND(SP, retcount); |
|
|
50
|
|
|
|
|
|
131
|
1
|
50
|
|
|
|
|
Copy(AvARRAY(retav), SP+1, retcount, SV *); |
132
|
1
|
|
|
|
|
|
SP += retcount; |
133
|
1
|
|
|
|
|
|
PUTBACK; |
134
|
1
|
|
|
|
|
|
break; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
7
|
|
|
|
|
|
return PL_ppaddr[OP_RETURN](aTHX); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
/* |
142
|
|
|
|
|
|
|
* A custom SVOP that takes a CV and arranges for it to be invoked on scope |
143
|
|
|
|
|
|
|
* leave |
144
|
|
|
|
|
|
|
*/ |
145
|
|
|
|
|
|
|
static XOP xop_pushfinally; |
146
|
|
|
|
|
|
|
|
147
|
8
|
|
|
|
|
|
static void invoke_finally(pTHX_ void *arg) |
148
|
|
|
|
|
|
|
{ |
149
|
|
|
|
|
|
|
CV *finally = arg; |
150
|
8
|
|
|
|
|
|
dSP; |
151
|
|
|
|
|
|
|
|
152
|
8
|
50
|
|
|
|
|
PUSHMARK(SP); |
153
|
8
|
|
|
|
|
|
call_sv((SV *)finally, G_DISCARD|G_EVAL|G_KEEPERR); |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
SvREFCNT_dec(finally); |
156
|
8
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
8
|
|
|
|
|
|
static OP *pp_pushfinally(pTHX) |
159
|
|
|
|
|
|
|
{ |
160
|
8
|
|
|
|
|
|
CV *finally = (CV *)cSVOP->op_sv; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
/* finally is a closure protosub; we have to clone it into a real sub. |
163
|
|
|
|
|
|
|
* If we do this now then captured lexicals still work even around |
164
|
|
|
|
|
|
|
* Future::AsyncAwait (see RT122796) |
165
|
|
|
|
|
|
|
* */ |
166
|
8
|
|
|
|
|
|
SAVEDESTRUCTOR_X(&invoke_finally, (SV *)cv_clone(finally)); |
167
|
8
|
|
|
|
|
|
return PL_op->op_next; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
#define newLOCALISEOP(gv) MY_newLOCALISEOP(aTHX_ gv) |
171
|
|
|
|
|
|
|
static OP *MY_newLOCALISEOP(pTHX_ GV *gv) |
172
|
|
|
|
|
|
|
{ |
173
|
|
|
|
|
|
|
OP *op = newGVOP(OP_GVSV, 0, gv); |
174
|
|
|
|
|
|
|
op->op_private |= OPpLVAL_INTRO; |
175
|
|
|
|
|
|
|
return op; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
#define newSTATEOP_nowarnings() MY_newSTATEOP_nowarnings(aTHX) |
179
|
2
|
|
|
|
|
|
static OP *MY_newSTATEOP_nowarnings(pTHX) |
180
|
|
|
|
|
|
|
{ |
181
|
2
|
|
|
|
|
|
OP *op = newSTATEOP(0, NULL, NULL); |
182
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5,37,6) |
183
|
|
|
|
|
|
|
/* cop_warnings no longer has the weird STRLEN prefix on it |
184
|
|
|
|
|
|
|
* https://github.com/Perl/perl5/pull/20469 |
185
|
|
|
|
|
|
|
*/ |
186
|
|
|
|
|
|
|
char *warnings = ((COP *)op)->cop_warnings; |
187
|
|
|
|
|
|
|
# define WARNING_BITS warnings |
188
|
|
|
|
|
|
|
#else |
189
|
2
|
|
|
|
|
|
STRLEN *warnings = ((COP *)op)->cop_warnings; |
190
|
|
|
|
|
|
|
# define WARNING_BITS (char *)(warnings + 1) |
191
|
|
|
|
|
|
|
#endif |
192
|
|
|
|
|
|
|
char *warning_bits; |
193
|
|
|
|
|
|
|
|
194
|
2
|
50
|
|
|
|
|
if(warnings == pWARN_NONE) |
195
|
|
|
|
|
|
|
return op; |
196
|
|
|
|
|
|
|
|
197
|
2
|
50
|
|
|
|
|
if(warnings == pWARN_STD) |
198
|
|
|
|
|
|
|
/* TODO: understand what STD vs ALL means */ |
199
|
|
|
|
|
|
|
warning_bits = WARN_ALLstring; |
200
|
2
|
50
|
|
|
|
|
else if(warnings == pWARN_ALL) |
201
|
|
|
|
|
|
|
warning_bits = WARN_ALLstring; |
202
|
|
|
|
|
|
|
else |
203
|
0
|
|
|
|
|
|
warning_bits = WARNING_BITS; |
204
|
|
|
|
|
|
|
|
205
|
2
|
|
|
|
|
|
warnings = Perl_new_warnings_bitfield(aTHX_ warnings, warning_bits, WARNsize); |
206
|
2
|
|
|
|
|
|
((COP *)op)->cop_warnings = warnings; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
warning_bits = WARNING_BITS; |
209
|
2
|
|
|
|
|
|
warning_bits[(2*WARN_EXITING) / 8] &= ~(1 << (2*WARN_EXITING % 8)); |
210
|
|
|
|
|
|
|
|
211
|
2
|
|
|
|
|
|
return op; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
#undef WARNING_BITS |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
14
|
|
|
|
|
|
static void rethread_op(OP *op, OP *old, OP *new) |
217
|
|
|
|
|
|
|
{ |
218
|
14
|
100
|
|
|
|
|
if(op->op_next == old) |
219
|
1
|
|
|
|
|
|
op->op_next = new; |
220
|
|
|
|
|
|
|
|
221
|
14
|
50
|
|
|
|
|
switch(OP_CLASS(op)) { |
222
|
|
|
|
|
|
|
case OA_LOGOP: |
223
|
1
|
50
|
|
|
|
|
if(cLOGOPx(op)->op_other == old) |
224
|
1
|
|
|
|
|
|
cLOGOPx(op)->op_other = new; |
225
|
|
|
|
|
|
|
break; |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
case OA_LISTOP: |
228
|
2
|
50
|
|
|
|
|
if(cLISTOPx(op)->op_last == old) |
229
|
0
|
|
|
|
|
|
cLISTOPx(op)->op_last = new; |
230
|
|
|
|
|
|
|
break; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
14
|
100
|
|
|
|
|
if(op->op_flags & OPf_KIDS) { |
234
|
|
|
|
|
|
|
OP *kid; |
235
|
18
|
100
|
|
|
|
|
for(kid = cUNOPx(op)->op_first; kid; kid = OpSIBLING(kid)) |
|
|
100
|
|
|
|
|
|
236
|
12
|
|
|
|
|
|
rethread_op(kid, old, new); |
237
|
|
|
|
|
|
|
} |
238
|
14
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
#define walk_optree_try_in_eval(op_ptr, root) MY_walk_optree_try_in_eval(aTHX_ op_ptr, root) |
241
|
|
|
|
|
|
|
static void MY_walk_optree_try_in_eval(pTHX_ OP **op_ptr, OP *root); |
242
|
260
|
|
|
|
|
|
static void MY_walk_optree_try_in_eval(pTHX_ OP **op_ptr, OP *root) |
243
|
|
|
|
|
|
|
{ |
244
|
260
|
|
|
|
|
|
OP *op = *op_ptr; |
245
|
|
|
|
|
|
|
|
246
|
260
|
|
|
|
|
|
switch(op->op_type) { |
247
|
|
|
|
|
|
|
/* Fix 'return' to unwind the CXt_EVAL block that implements try{} first */ |
248
|
|
|
|
|
|
|
case OP_RETURN: |
249
|
7
|
|
|
|
|
|
op->op_ppaddr = &pp_returnintry; |
250
|
7
|
|
|
|
|
|
break; |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
/* wrap no warnings 'exiting' around loop controls */ |
253
|
|
|
|
|
|
|
case OP_NEXT: |
254
|
|
|
|
|
|
|
case OP_LAST: |
255
|
|
|
|
|
|
|
case OP_REDO: |
256
|
|
|
|
|
|
|
{ |
257
|
|
|
|
|
|
|
#ifdef HAVE_OP_SIBPARENT |
258
|
2
|
100
|
|
|
|
|
OP *parent = OpHAS_SIBLING(op) ? NULL : op->op_sibparent; |
259
|
|
|
|
|
|
|
#endif |
260
|
|
|
|
|
|
|
|
261
|
2
|
|
|
|
|
|
OP *stateop = newSTATEOP_nowarnings(); |
262
|
|
|
|
|
|
|
|
263
|
2
|
|
|
|
|
|
OP *scope = newLISTOP(OP_SCOPE, 0, |
264
|
|
|
|
|
|
|
stateop, op); |
265
|
|
|
|
|
|
|
#ifdef HAVE_OP_SIBPARENT |
266
|
2
|
100
|
|
|
|
|
if(parent) |
267
|
1
|
|
|
|
|
|
OpLASTSIB_set(scope, parent); |
268
|
|
|
|
|
|
|
else |
269
|
1
|
|
|
|
|
|
OpLASTSIB_set(scope, NULL); |
270
|
|
|
|
|
|
|
#else |
271
|
|
|
|
|
|
|
op->op_sibling = NULL; |
272
|
|
|
|
|
|
|
#endif |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
/* Rethread */ |
275
|
2
|
|
|
|
|
|
scope->op_next = stateop; |
276
|
2
|
|
|
|
|
|
stateop->op_next = op; |
277
|
|
|
|
|
|
|
|
278
|
2
|
|
|
|
|
|
*op_ptr = scope; |
279
|
|
|
|
|
|
|
} |
280
|
2
|
|
|
|
|
|
break; |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
/* Don't enter inside nested eval{} blocks */ |
283
|
|
|
|
|
|
|
case OP_LEAVETRY: |
284
|
|
|
|
|
|
|
return; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
258
|
100
|
|
|
|
|
if(op->op_flags & OPf_KIDS) { |
288
|
|
|
|
|
|
|
OP *kid, *next, *prev = NULL; |
289
|
334
|
100
|
|
|
|
|
for(kid = cUNOPx(op)->op_first; kid; kid = next) { |
290
|
222
|
|
|
|
|
|
OP *newkid = kid; |
291
|
222
|
100
|
|
|
|
|
next = OpSIBLING(kid); |
292
|
|
|
|
|
|
|
|
293
|
222
|
|
|
|
|
|
walk_optree_try_in_eval(&newkid, root); |
294
|
|
|
|
|
|
|
|
295
|
222
|
100
|
|
|
|
|
if(newkid != kid) { |
296
|
2
|
|
|
|
|
|
rethread_op(root, kid, newkid); |
297
|
|
|
|
|
|
|
|
298
|
2
|
50
|
|
|
|
|
if(prev) { |
299
|
2
|
|
|
|
|
|
OpMORESIB_set(prev, newkid); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
else |
302
|
0
|
|
|
|
|
|
cUNOPx(op)->op_first = newkid; |
303
|
|
|
|
|
|
|
|
304
|
2
|
100
|
|
|
|
|
if(next) |
305
|
222
|
|
|
|
|
|
OpMORESIB_set(newkid, next); |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
prev = kid; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
43
|
|
|
|
|
|
static OP *pp_entertrycatch(pTHX) |
314
|
|
|
|
|
|
|
{ |
315
|
|
|
|
|
|
|
/* Localise the errgv */ |
316
|
43
|
|
|
|
|
|
save_scalar(PL_errgv); |
317
|
|
|
|
|
|
|
|
318
|
43
|
|
|
|
|
|
return PL_ppaddr[OP_ENTERTRY](aTHX); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
static XOP xop_catch; |
322
|
|
|
|
|
|
|
|
323
|
33
|
|
|
|
|
|
static OP *pp_catch(pTHX) |
324
|
|
|
|
|
|
|
{ |
325
|
|
|
|
|
|
|
/* If an error didn't happen, then ERRSV will be both not true and not a |
326
|
|
|
|
|
|
|
* reference. If it's a reference, then an error definitely happened |
327
|
|
|
|
|
|
|
*/ |
328
|
33
|
50
|
|
|
|
|
if(SvROK(ERRSV) || SvTRUE(ERRSV)) |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
329
|
22
|
|
|
|
|
|
return cLOGOP->op_other; |
330
|
|
|
|
|
|
|
else |
331
|
11
|
|
|
|
|
|
return cLOGOP->op_next; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
#define newENTERTRYCATCHOP(flags, try, catch) MY_newENTERTRYCATCHOP(aTHX_ flags, try, catch) |
335
|
76
|
|
|
|
|
|
static OP *MY_newENTERTRYCATCHOP(pTHX_ U32 flags, OP *try, OP *catch) |
336
|
|
|
|
|
|
|
{ |
337
|
|
|
|
|
|
|
OP *enter, *entertry, *ret; |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
/* Walk the block for OP_RETURN ops, so we can apply a hack to them to |
340
|
|
|
|
|
|
|
* make |
341
|
|
|
|
|
|
|
* try { return } |
342
|
|
|
|
|
|
|
* return from the containing sub, not just the eval block |
343
|
|
|
|
|
|
|
*/ |
344
|
38
|
|
|
|
|
|
walk_optree_try_in_eval(&try, try); |
345
|
|
|
|
|
|
|
|
346
|
38
|
|
|
|
|
|
enter = newUNOP(OP_ENTERTRY, 0, try); |
347
|
|
|
|
|
|
|
/* despite calling newUNOP(OP_ENTERTRY,...) the returned root node is the |
348
|
|
|
|
|
|
|
* OP_LEAVETRY, whose first child is the ENTERTRY we wanted |
349
|
|
|
|
|
|
|
*/ |
350
|
38
|
|
|
|
|
|
entertry = ((UNOP *)enter)->op_first; |
351
|
38
|
|
|
|
|
|
entertry->op_ppaddr = &pp_entertrycatch; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
/* If we call newLOGOP_CUSTOM it will op_contextualize the enter block into |
354
|
|
|
|
|
|
|
* G_SCALAR. This is not what we want |
355
|
|
|
|
|
|
|
*/ |
356
|
|
|
|
|
|
|
{ |
357
|
|
|
|
|
|
|
LOGOP *logop; |
358
|
|
|
|
|
|
|
|
359
|
38
|
|
|
|
|
|
OP *first = enter, *other = newLISTOP(OP_SCOPE, 0, catch, NULL); |
360
|
|
|
|
|
|
|
|
361
|
38
|
|
|
|
|
|
NewOp(1101, logop, 1, LOGOP); |
362
|
|
|
|
|
|
|
|
363
|
38
|
|
|
|
|
|
logop->op_type = OP_CUSTOM; |
364
|
38
|
|
|
|
|
|
logop->op_ppaddr = &pp_catch; |
365
|
38
|
|
|
|
|
|
logop->op_first = first; |
366
|
38
|
|
|
|
|
|
logop->op_flags = OPf_KIDS; |
367
|
38
|
50
|
|
|
|
|
logop->op_other = LINKLIST(other); |
368
|
|
|
|
|
|
|
|
369
|
38
|
50
|
|
|
|
|
logop->op_next = LINKLIST(first); |
370
|
38
|
|
|
|
|
|
enter->op_next = (OP *)logop; |
371
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5, 22, 0) |
372
|
38
|
|
|
|
|
|
op_sibling_splice((OP *)logop, first, 0, other); |
373
|
|
|
|
|
|
|
#else |
374
|
|
|
|
|
|
|
first->op_sibling = other; |
375
|
|
|
|
|
|
|
#endif |
376
|
|
|
|
|
|
|
|
377
|
38
|
|
|
|
|
|
ret = newUNOP(OP_NULL, 0, (OP *)logop); |
378
|
38
|
|
|
|
|
|
other->op_next = ret; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
38
|
|
|
|
|
|
return ret; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
#ifndef HAVE_OP_ISA |
385
|
|
|
|
|
|
|
static XOP xop_isa; |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
/* Totally stolen from perl 5.32.0's pp.c */ |
388
|
|
|
|
|
|
|
#define sv_isa_sv(sv, namesv) S_sv_isa_sv(aTHX_ sv, namesv) |
389
|
5
|
|
|
|
|
|
static bool S_sv_isa_sv(pTHX_ SV *sv, SV *namesv) |
390
|
|
|
|
|
|
|
{ |
391
|
5
|
100
|
|
|
|
|
if(!SvROK(sv) || !SvOBJECT(SvRV(sv))) |
|
|
50
|
|
|
|
|
|
392
|
|
|
|
|
|
|
return FALSE; |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
/* TODO: ->isa invocation */ |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5,16,0) |
397
|
2
|
|
|
|
|
|
return sv_derived_from_sv(sv, namesv, 0); |
398
|
|
|
|
|
|
|
#else |
399
|
|
|
|
|
|
|
return sv_derived_from(sv, SvPV_nolen(namesv)); |
400
|
|
|
|
|
|
|
#endif |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
5
|
|
|
|
|
|
static OP *pp_isa(pTHX) |
404
|
|
|
|
|
|
|
{ |
405
|
5
|
|
|
|
|
|
dSP; |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
SV *left, *right; |
408
|
|
|
|
|
|
|
|
409
|
5
|
|
|
|
|
|
right = POPs; |
410
|
5
|
|
|
|
|
|
left = TOPs; |
411
|
|
|
|
|
|
|
|
412
|
5
|
100
|
|
|
|
|
SETs(boolSV(sv_isa_sv(left, right))); |
413
|
5
|
|
|
|
|
|
RETURN; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
#endif |
416
|
|
|
|
|
|
|
|
417
|
47
|
|
|
|
|
|
static int build_try(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata) |
418
|
|
|
|
|
|
|
{ |
419
|
|
|
|
|
|
|
U32 argi = 0; |
420
|
|
|
|
|
|
|
|
421
|
47
|
|
|
|
|
|
OP *try = args[argi++]->op; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
OP *ret = NULL; |
424
|
47
|
|
|
|
|
|
HV *hints = GvHV(PL_hintgv); |
425
|
|
|
|
|
|
|
|
426
|
47
|
50
|
|
|
|
|
bool require_catch = hints && hv_fetchs(hints, "Syntax::Keyword::Try/require_catch", 0); |
|
|
50
|
|
|
|
|
|
427
|
47
|
50
|
|
|
|
|
bool require_var = hints && hv_fetchs(hints, "Syntax::Keyword::Try/require_var", 0); |
|
|
100
|
|
|
|
|
|
428
|
|
|
|
|
|
|
|
429
|
47
|
|
|
|
|
|
U32 ncatches = args[argi++]->i; |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
AV *condcatch = NULL; |
432
|
|
|
|
|
|
|
OP *catch = NULL; |
433
|
87
|
100
|
|
|
|
|
while(ncatches--) { |
434
|
41
|
|
|
|
|
|
bool has_catchvar = args[argi++]->i; |
435
|
41
|
100
|
|
|
|
|
PADOFFSET catchvar = has_catchvar ? args[argi++]->padix : 0; |
436
|
41
|
100
|
|
|
|
|
int catchtype = has_catchvar ? args[argi++]->i : -1; |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
bool warned = FALSE; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
OP *condop = NULL; |
441
|
|
|
|
|
|
|
|
442
|
41
|
|
|
|
|
|
switch(catchtype) { |
443
|
|
|
|
|
|
|
case -1: /* no type */ |
444
|
|
|
|
|
|
|
break; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
case 0: /* isa */ |
447
|
|
|
|
|
|
|
{ |
448
|
2
|
|
|
|
|
|
OP *type = args[argi++]->op; |
449
|
|
|
|
|
|
|
#ifdef HAVE_OP_ISA |
450
|
|
|
|
|
|
|
condop = newBINOP(OP_ISA, 0, |
451
|
|
|
|
|
|
|
newPADxVOP(OP_PADSV, 0, catchvar), type); |
452
|
|
|
|
|
|
|
#else |
453
|
|
|
|
|
|
|
/* Allow a bareword on RHS of `isa` */ |
454
|
2
|
50
|
|
|
|
|
if(type->op_type == OP_CONST) |
455
|
2
|
|
|
|
|
|
type->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT); |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
condop = newBINOP_CUSTOM(&pp_isa, 0, |
458
|
|
|
|
|
|
|
newPADxVOP(OP_PADSV, 0, catchvar), type); |
459
|
|
|
|
|
|
|
#endif |
460
|
2
|
|
|
|
|
|
break; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
case 1: /* =~ */ |
464
|
|
|
|
|
|
|
{ |
465
|
1
|
|
|
|
|
|
OP *regexp = args[argi++]->op; |
466
|
|
|
|
|
|
|
|
467
|
1
|
50
|
|
|
|
|
if(regexp->op_type != OP_MATCH || cPMOPx(regexp)->op_first) |
|
|
50
|
|
|
|
|
|
468
|
0
|
|
|
|
|
|
croak("Expected a regexp match"); |
469
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5,22,0) |
470
|
|
|
|
|
|
|
/* Perl 5.22+ uses op_targ on OP_MATCH directly */ |
471
|
1
|
|
|
|
|
|
regexp->op_targ = catchvar; |
472
|
|
|
|
|
|
|
#else |
473
|
|
|
|
|
|
|
/* Older perls need a stacked OP_PADSV op */ |
474
|
|
|
|
|
|
|
cPMOPx(regexp)->op_first = newPADxVOP(OP_PADSV, 0, catchvar); |
475
|
|
|
|
|
|
|
regexp->op_flags |= OPf_KIDS|OPf_STACKED; |
476
|
|
|
|
|
|
|
#endif |
477
|
|
|
|
|
|
|
condop = regexp; |
478
|
1
|
|
|
|
|
|
break; |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
default: |
482
|
0
|
|
|
|
|
|
croak("TODO\n"); |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
#ifdef WARN_EXPERIMENTAL |
486
|
41
|
100
|
|
|
|
|
if(condop && !warned && |
|
|
50
|
|
|
|
|
|
487
|
3
|
50
|
|
|
|
|
(!hints || !hv_fetchs(hints, "Syntax::Keyword::Try/experimental(typed)", 0))) { |
488
|
|
|
|
|
|
|
warned = true; |
489
|
0
|
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL), |
490
|
|
|
|
|
|
|
"typed catch syntax is experimental and may be changed or removed without notice"); |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
#endif |
493
|
|
|
|
|
|
|
|
494
|
41
|
|
|
|
|
|
OP *body = args[argi++]->op; |
495
|
|
|
|
|
|
|
|
496
|
41
|
100
|
|
|
|
|
if(require_var && !has_catchvar) |
497
|
1
|
|
|
|
|
|
croak("Expected (VAR) for catch"); |
498
|
|
|
|
|
|
|
|
499
|
40
|
50
|
|
|
|
|
if(catch) |
500
|
0
|
|
|
|
|
|
croak("Already have a default catch {} block"); |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
OP *assignop = NULL; |
503
|
40
|
100
|
|
|
|
|
if(catchvar) { |
504
|
|
|
|
|
|
|
/* my $var = $@ */ |
505
|
37
|
|
|
|
|
|
assignop = newBINOP(OP_SASSIGN, 0, |
506
|
|
|
|
|
|
|
newGVOP(OP_GVSV, 0, PL_errgv), newPADxVOP(OP_PADSV, OPf_MOD | OPpLVAL_INTRO << 8, catchvar)); |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
40
|
100
|
|
|
|
|
if(condop) { |
510
|
3
|
100
|
|
|
|
|
if(!condcatch) |
511
|
2
|
|
|
|
|
|
condcatch = newAV(); |
512
|
|
|
|
|
|
|
|
513
|
3
|
|
|
|
|
|
av_push(condcatch, (SV *)op_append_elem(OP_LINESEQ, assignop, condop)); |
514
|
3
|
|
|
|
|
|
av_push(condcatch, (SV *)body); |
515
|
|
|
|
|
|
|
/* catch remains NULL for now */ |
516
|
|
|
|
|
|
|
} |
517
|
37
|
100
|
|
|
|
|
else if(assignop) { |
518
|
40
|
|
|
|
|
|
catch = op_prepend_elem(OP_LINESEQ, |
519
|
|
|
|
|
|
|
assignop, body); |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
else |
522
|
|
|
|
|
|
|
catch = body; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
46
|
100
|
|
|
|
|
if(condcatch) { |
526
|
|
|
|
|
|
|
I32 i; |
527
|
|
|
|
|
|
|
|
528
|
2
|
100
|
|
|
|
|
if(!catch) |
529
|
|
|
|
|
|
|
/* A default fallthrough */ |
530
|
|
|
|
|
|
|
/* die $@ */ |
531
|
1
|
|
|
|
|
|
catch = newLISTOP(OP_DIE, 0, |
532
|
|
|
|
|
|
|
newOP(OP_PUSHMARK, 0), newGVOP(OP_GVSV, 0, PL_errgv)); |
533
|
|
|
|
|
|
|
|
534
|
5
|
50
|
|
|
|
|
for(i = AvFILL(condcatch)-1; i >= 0; i -= 2) { |
|
|
100
|
|
|
|
|
|
535
|
3
|
|
|
|
|
|
OP *body = (OP *)av_pop(condcatch), |
536
|
3
|
|
|
|
|
|
*condop = (OP *)av_pop(condcatch); |
537
|
|
|
|
|
|
|
|
538
|
3
|
|
|
|
|
|
catch = newCONDOP(0, condop, op_scope(body), catch); |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
SvREFCNT_dec(condcatch); |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
46
|
50
|
|
|
|
|
if(require_catch && !catch) |
545
|
0
|
|
|
|
|
|
croak("Expected a catch {} block"); |
546
|
|
|
|
|
|
|
|
547
|
46
|
50
|
|
|
|
|
bool no_finally = hints && hv_fetchs(hints, "Syntax::Keyword::Try/no_finally", 0); |
|
|
100
|
|
|
|
|
|
548
|
|
|
|
|
|
|
|
549
|
46
|
|
|
|
|
|
U32 has_finally = args[argi++]->i; |
550
|
46
|
100
|
|
|
|
|
CV *finally = has_finally ? args[argi++]->cv : NULL; |
551
|
|
|
|
|
|
|
|
552
|
46
|
100
|
|
|
|
|
if(no_finally && finally) |
553
|
1
|
|
|
|
|
|
croak("finally {} is not permitted here"); |
554
|
|
|
|
|
|
|
|
555
|
45
|
50
|
|
|
|
|
if(!catch && !finally) { |
556
|
0
|
|
|
|
|
|
op_free(try); |
557
|
0
|
0
|
|
|
|
|
croak(no_finally |
558
|
|
|
|
|
|
|
? "Expected try {} to be followed by catch {}" |
559
|
|
|
|
|
|
|
: "Expected try {} to be followed by either catch {} or finally {}"); |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
ret = try; |
563
|
|
|
|
|
|
|
|
564
|
45
|
100
|
|
|
|
|
if(catch) { |
565
|
38
|
|
|
|
|
|
ret = newENTERTRYCATCHOP(0, try, catch); |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
/* If there's a finally, make |
569
|
|
|
|
|
|
|
* $RET = OP_PUSHFINALLY($FINALLY); $RET |
570
|
|
|
|
|
|
|
*/ |
571
|
45
|
100
|
|
|
|
|
if(finally) { |
572
|
10
|
|
|
|
|
|
ret = op_prepend_elem(OP_LINESEQ, |
573
|
|
|
|
|
|
|
newSVOP_CUSTOM(&pp_pushfinally, 0, (SV *)finally), |
574
|
|
|
|
|
|
|
ret); |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
|
577
|
45
|
|
|
|
|
|
ret = op_append_list(OP_LEAVE, |
578
|
|
|
|
|
|
|
newOP(OP_ENTER, 0), |
579
|
|
|
|
|
|
|
ret); |
580
|
|
|
|
|
|
|
|
581
|
45
|
|
|
|
|
|
*out = ret; |
582
|
45
|
|
|
|
|
|
return KEYWORD_PLUGIN_STMT; |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
static struct XSParseKeywordHooks hooks_try = { |
586
|
|
|
|
|
|
|
.permit_hintkey = "Syntax::Keyword::Try/try", |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
.pieces = (const struct XSParseKeywordPieceType []){ |
589
|
|
|
|
|
|
|
XPK_BLOCK, |
590
|
|
|
|
|
|
|
XPK_REPEATED( |
591
|
|
|
|
|
|
|
XPK_LITERAL("catch"), |
592
|
|
|
|
|
|
|
XPK_PREFIXED_BLOCK( |
593
|
|
|
|
|
|
|
/* optionally ($var), ($var isa Type) or ($var =~ m/.../) */ |
594
|
|
|
|
|
|
|
XPK_PARENSCOPE_OPT( |
595
|
|
|
|
|
|
|
XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR), |
596
|
|
|
|
|
|
|
XPK_CHOICE( |
597
|
|
|
|
|
|
|
XPK_SEQUENCE(XPK_LITERAL("isa"), XPK_TERMEXPR), |
598
|
|
|
|
|
|
|
XPK_SEQUENCE(XPK_LITERAL("=~"), XPK_TERMEXPR) |
599
|
|
|
|
|
|
|
) |
600
|
|
|
|
|
|
|
) |
601
|
|
|
|
|
|
|
) |
602
|
|
|
|
|
|
|
), |
603
|
|
|
|
|
|
|
XPK_OPTIONAL( |
604
|
|
|
|
|
|
|
XPK_LITERAL("finally"), XPK_ANONSUB |
605
|
|
|
|
|
|
|
), |
606
|
|
|
|
|
|
|
{0}, |
607
|
|
|
|
|
|
|
}, |
608
|
|
|
|
|
|
|
.build = &build_try, |
609
|
|
|
|
|
|
|
}; |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
MODULE = Syntax::Keyword::Try PACKAGE = Syntax::Keyword::Try |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
BOOT: |
614
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_catch, xop_name, "catch"); |
615
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_catch, xop_desc, |
616
|
|
|
|
|
|
|
"optionally invoke the catch block if required"); |
617
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_catch, xop_class, OA_LOGOP); |
618
|
15
|
|
|
|
|
|
Perl_custom_op_register(aTHX_ &pp_catch, &xop_catch); |
619
|
|
|
|
|
|
|
|
620
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_pushfinally, xop_name, "pushfinally"); |
621
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_pushfinally, xop_desc, |
622
|
|
|
|
|
|
|
"arrange for a CV to be invoked at scope exit"); |
623
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_pushfinally, xop_class, OA_SVOP); |
624
|
15
|
|
|
|
|
|
Perl_custom_op_register(aTHX_ &pp_pushfinally, &xop_pushfinally); |
625
|
|
|
|
|
|
|
#ifndef HAVE_OP_ISA |
626
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_isa, xop_name, "isa"); |
627
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_isa, xop_desc, |
628
|
|
|
|
|
|
|
"check if a value is an object of the given class"); |
629
|
15
|
|
|
|
|
|
XopENTRY_set(&xop_isa, xop_class, OA_BINOP); |
630
|
15
|
|
|
|
|
|
Perl_custom_op_register(aTHX_ &pp_isa, &xop_isa); |
631
|
|
|
|
|
|
|
#endif |
632
|
|
|
|
|
|
|
|
633
|
15
|
|
|
|
|
|
boot_xs_parse_keyword(0.06); |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
register_xs_parse_keyword("try", &hooks_try, NULL); |