line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* pp_ctl.c |
2
|
|
|
|
|
|
* |
3
|
|
|
|
|
|
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
4
|
|
|
|
|
|
* 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others |
5
|
|
|
|
|
|
* |
6
|
|
|
|
|
|
* You may distribute under the terms of either the GNU General Public |
7
|
|
|
|
|
|
* License or the Artistic License, as specified in the README file. |
8
|
|
|
|
|
|
* |
9
|
|
|
|
|
|
*/ |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
/* |
12
|
|
|
|
|
|
* Now far ahead the Road has gone, |
13
|
|
|
|
|
|
* And I must follow, if I can, |
14
|
|
|
|
|
|
* Pursuing it with eager feet, |
15
|
|
|
|
|
|
* Until it joins some larger way |
16
|
|
|
|
|
|
* Where many paths and errands meet. |
17
|
|
|
|
|
|
* And whither then? I cannot say. |
18
|
|
|
|
|
|
* |
19
|
|
|
|
|
|
* [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] |
20
|
|
|
|
|
|
*/ |
21
|
|
|
|
|
|
|
22
|
|
|
|
|
|
/* This file contains control-oriented pp ("push/pop") functions that |
23
|
|
|
|
|
|
* execute the opcodes that make up a perl program. A typical pp function |
24
|
|
|
|
|
|
* expects to find its arguments on the stack, and usually pushes its |
25
|
|
|
|
|
|
* results onto the stack, hence the 'pp' terminology. Each OP structure |
26
|
|
|
|
|
|
* contains a pointer to the relevant pp_foo() function. |
27
|
|
|
|
|
|
* |
28
|
|
|
|
|
|
* Control-oriented means things like pp_enteriter() and pp_next(), which |
29
|
|
|
|
|
|
* alter the flow of control of the program. |
30
|
|
|
|
|
|
*/ |
31
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
33
|
|
|
|
|
|
#include "EXTERN.h" |
34
|
|
|
|
|
|
#define PERL_IN_PP_CTL_C |
35
|
|
|
|
|
|
#include "perl.h" |
36
|
|
|
|
|
|
|
37
|
|
|
|
|
|
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) |
38
|
|
|
|
|
|
|
39
|
|
|
|
|
|
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) |
40
|
|
|
|
|
|
|
41
|
5278598
|
|
|
|
|
PP(pp_wantarray) |
42
|
5278598
|
50
|
|
|
|
{ |
43
|
|
|
|
|
|
dVAR; |
44
|
5278598
|
|
|
|
|
dSP; |
45
|
|
|
|
|
|
I32 cxix; |
46
|
|
|
|
|
|
const PERL_CONTEXT *cx; |
47
|
2639299
|
|
|
|
|
EXTEND(SP, 1); |
48
|
|
|
|
|
|
|
49
|
5278598
|
100
|
|
|
|
if (PL_op->op_private & OPpOFFBYONE) { |
50
|
16
|
100
|
|
|
|
if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; |
51
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
else { |
53
|
5278582
|
|
|
|
|
cxix = dopoptosub(cxstack_ix); |
54
|
5278582
|
100
|
|
|
|
if (cxix < 0) |
55
|
6
|
|
|
|
|
RETPUSHUNDEF; |
56
|
5278576
|
|
|
|
|
cx = &cxstack[cxix]; |
57
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
59
|
5278588
|
|
|
|
|
switch (cx->blk_gimme) { |
60
|
|
|
|
|
|
case G_ARRAY: |
61
|
1226564
|
|
|
|
|
RETPUSHYES; |
62
|
|
|
|
|
|
case G_SCALAR: |
63
|
3003162
|
|
|
|
|
RETPUSHNO; |
64
|
|
|
|
|
|
default: |
65
|
3163730
|
|
|
|
|
RETPUSHUNDEF; |
66
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
69
|
52556
|
|
|
|
|
PP(pp_regcreset) |
70
|
|
|
|
|
|
{ |
71
|
|
|
|
|
|
dVAR; |
72
|
52556
|
|
|
|
|
TAINT_NOT; |
73
|
52556
|
|
|
|
|
return NORMAL; |
74
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
76
|
22326134
|
|
|
|
|
PP(pp_regcomp) |
77
|
|
|
|
|
|
{ |
78
|
|
|
|
|
|
dVAR; |
79
|
22326134
|
|
|
|
|
dSP; |
80
|
22326134
|
|
|
|
|
PMOP *pm = (PMOP*)cLOGOP->op_other; |
81
|
|
|
|
|
|
SV **args; |
82
|
|
|
|
|
|
int nargs; |
83
|
|
|
|
|
|
REGEXP *re = NULL; |
84
|
|
|
|
|
|
REGEXP *new_re; |
85
|
|
|
|
|
|
const regexp_engine *eng; |
86
|
22326134
|
|
|
|
|
bool is_bare_re= FALSE; |
87
|
|
|
|
|
|
|
88
|
22326134
|
100
|
|
|
|
if (PL_op->op_flags & OPf_STACKED) { |
89
|
7430889
|
|
|
|
|
dMARK; |
90
|
7430889
|
|
|
|
|
nargs = SP - MARK; |
91
|
7430889
|
|
|
|
|
args = ++MARK; |
92
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
else { |
94
|
|
|
|
|
|
nargs = 1; |
95
|
|
|
|
|
|
args = SP; |
96
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
98
|
|
|
|
|
|
/* prevent recompiling under /o and ithreads. */ |
99
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
100
|
|
|
|
|
|
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { |
101
|
|
|
|
|
|
SP = args-1; |
102
|
|
|
|
|
|
RETURN; |
103
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
#endif |
105
|
|
|
|
|
|
|
106
|
22326134
|
|
|
|
|
re = PM_GETRE(pm); |
107
|
|
|
|
|
|
assert (re != (REGEXP*) &PL_sv_undef); |
108
|
33067953
|
100
|
|
|
|
eng = re ? RX_ENGINE(re) : current_re_engine(); |
109
|
|
|
|
|
|
|
110
|
|
|
|
|
|
/* |
111
|
|
|
|
|
|
In the below logic: these are basically the same - check if this regcomp is part of a split. |
112
|
|
|
|
|
|
|
113
|
|
|
|
|
|
(PL_op->op_pmflags & PMf_split ) |
114
|
|
|
|
|
|
(PL_op->op_next->op_type == OP_PUSHRE) |
115
|
|
|
|
|
|
|
116
|
|
|
|
|
|
We could add a new mask for this and copy the PMf_split, if we did |
117
|
|
|
|
|
|
some bit definition fiddling first. |
118
|
|
|
|
|
|
|
119
|
|
|
|
|
|
For now we leave this |
120
|
|
|
|
|
|
*/ |
121
|
|
|
|
|
|
|
122
|
33292981
|
|
|
|
|
new_re = (eng->op_comp |
123
|
|
|
|
|
|
? eng->op_comp |
124
|
22326134
|
50
|
|
|
|
: &Perl_re_op_compile |
125
|
33292981
|
100
|
|
|
|
)(aTHX_ args, nargs, pm->op_code_list, eng, re, |
126
|
|
|
|
|
|
&is_bare_re, |
127
|
22326134
|
|
|
|
|
(pm->op_pmflags & RXf_PMf_FLAGCOPYMASK), |
128
|
22326134
|
|
|
|
|
pm->op_pmflags | |
129
|
22326134
|
|
|
|
|
(PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); |
130
|
|
|
|
|
|
|
131
|
22323860
|
100
|
|
|
|
if (pm->op_pmflags & PMf_HAS_CV) |
132
|
|
|
|
|
|
ReANY(new_re)->qr_anoncv |
133
|
12
|
|
|
|
|
= (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); |
134
|
|
|
|
|
|
|
135
|
22323860
|
100
|
|
|
|
if (is_bare_re) { |
136
|
|
|
|
|
|
REGEXP *tmp; |
137
|
|
|
|
|
|
/* The match's LHS's get-magic might need to access this op's regexp |
138
|
|
|
|
|
|
(e.g. $' =~ /$re/ while foo; see bug 70764). So we must call |
139
|
|
|
|
|
|
get-magic now before we replace the regexp. Hopefully this hack can |
140
|
|
|
|
|
|
be replaced with the approach described at |
141
|
|
|
|
|
|
http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html |
142
|
|
|
|
|
|
some day. */ |
143
|
26359798
|
100
|
|
|
|
if (pm->op_type == OP_MATCH) { |
|
|
100
|
|
|
|
|
144
|
|
|
|
|
|
SV *lhs; |
145
|
12931823
|
|
|
|
|
const bool was_tainted = TAINT_get; |
146
|
12931823
|
100
|
|
|
|
if (pm->op_flags & OPf_STACKED) |
147
|
10808297
|
|
|
|
|
lhs = args[-1]; |
148
|
2123526
|
100
|
|
|
|
else if (pm->op_private & OPpTARGET_MY) |
149
|
8
|
|
|
|
|
lhs = PAD_SV(pm->op_targ); |
150
|
2123518
|
50
|
|
|
|
else lhs = DEFSV; |
151
|
6277835
|
|
|
|
|
SvGETMAGIC(lhs); |
152
|
|
|
|
|
|
/* Restore the previous value of PL_tainted (which may have been |
153
|
|
|
|
|
|
modified by get-magic), to avoid incorrectly setting the |
154
|
|
|
|
|
|
RXf_TAINTED flag with RX_TAINT_on further down. */ |
155
|
12931823
|
|
|
|
|
TAINT_set(was_tainted); |
156
|
|
|
|
|
|
#if NO_TAINT_SUPPORT |
157
|
|
|
|
|
|
PERL_UNUSED_VAR(was_tainted); |
158
|
|
|
|
|
|
#endif |
159
|
|
|
|
|
|
} |
160
|
13427975
|
|
|
|
|
tmp = reg_temp_copy(NULL, new_re); |
161
|
13427975
|
|
|
|
|
ReREFCNT_dec(new_re); |
162
|
|
|
|
|
|
new_re = tmp; |
163
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
165
|
22323860
|
100
|
|
|
|
if (re != new_re) { |
166
|
17407710
|
|
|
|
|
ReREFCNT_dec(re); |
167
|
17407710
|
|
|
|
|
PM_SETRE(pm, new_re); |
168
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
171
|
|
|
|
|
|
#ifndef INCOMPLETE_TAINTS |
172
|
22323860
|
100
|
|
|
|
if (TAINTING_get && TAINT_get) { |
|
|
100
|
|
|
|
|
173
|
17596
|
50
|
|
|
|
SvTAINTED_on((SV*)new_re); |
174
|
17596
|
|
|
|
|
RX_TAINT_on(new_re); |
175
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
#endif |
177
|
|
|
|
|
|
|
178
|
|
|
|
|
|
#if !defined(USE_ITHREADS) |
179
|
|
|
|
|
|
/* can't change the optree at runtime either */ |
180
|
|
|
|
|
|
/* PMf_KEEP is handled differently under threads to avoid these problems */ |
181
|
33289570
|
100
|
|
|
|
if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) |
|
|
100
|
|
|
|
|
182
|
34
|
|
|
|
|
pm = PL_curpm; |
183
|
22323860
|
100
|
|
|
|
if (pm->op_pmflags & PMf_KEEP) { |
184
|
4212
|
|
|
|
|
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ |
185
|
4212
|
|
|
|
|
cLOGOP->op_first->op_next = PL_op->op_next; |
186
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
#endif |
188
|
|
|
|
|
|
|
189
|
22323860
|
|
|
|
|
SP = args-1; |
190
|
22323860
|
|
|
|
|
RETURN; |
191
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
194
|
12964146
|
|
|
|
|
PP(pp_substcont) |
195
|
|
|
|
|
|
{ |
196
|
|
|
|
|
|
dVAR; |
197
|
12964146
|
|
|
|
|
dSP; |
198
|
12964146
|
|
|
|
|
PERL_CONTEXT *cx = &cxstack[cxstack_ix]; |
199
|
12964146
|
|
|
|
|
PMOP * const pm = (PMOP*) cLOGOP->op_other; |
200
|
12964146
|
|
|
|
|
SV * const dstr = cx->sb_dstr; |
201
|
12964146
|
|
|
|
|
char *s = cx->sb_s; |
202
|
12964146
|
|
|
|
|
char *m = cx->sb_m; |
203
|
12964146
|
|
|
|
|
char *orig = cx->sb_orig; |
204
|
12964146
|
|
|
|
|
REGEXP * const rx = cx->sb_rx; |
205
|
|
|
|
|
|
SV *nsv = NULL; |
206
|
12964146
|
|
|
|
|
REGEXP *old = PM_GETRE(pm); |
207
|
|
|
|
|
|
|
208
|
12964146
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
209
|
|
|
|
|
|
|
210
|
12964146
|
100
|
|
|
|
if(old != rx) { |
211
|
22
|
50
|
|
|
|
if(old) |
212
|
22
|
|
|
|
|
ReREFCNT_dec(old); |
213
|
22
|
|
|
|
|
PM_SETRE(pm,ReREFCNT_inc(rx)); |
214
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
216
|
12964146
|
|
|
|
|
rxres_restore(&cx->sb_rxres, rx); |
217
|
|
|
|
|
|
|
218
|
24614865
|
100
|
|
|
|
if (cx->sb_iters++) { |
|
|
100
|
|
|
|
|
219
|
11650719
|
|
|
|
|
const I32 saviters = cx->sb_iters; |
220
|
11650719
|
50
|
|
|
|
if (cx->sb_iters > cx->sb_maxiters) |
221
|
0
|
|
|
|
|
DIE(aTHX_ "Substitution loop"); |
222
|
|
|
|
|
|
|
223
|
15087920
|
|
|
|
|
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ |
224
|
|
|
|
|
|
|
225
|
|
|
|
|
|
/* See "how taint works" above pp_subst() */ |
226
|
11650719
|
100
|
|
|
|
if (SvTAINTED(TOPs)) |
|
|
50
|
|
|
|
|
227
|
0
|
|
|
|
|
cx->sb_rxtainted |= SUBST_TAINT_REPL; |
228
|
11650719
|
|
|
|
|
sv_catsv_nomg(dstr, POPs); |
229
|
23019961
|
|
|
|
|
if (CxONCE(cx) || s < orig || |
230
|
11369242
|
|
|
|
|
!CALLREGEXEC(rx, s, cx->sb_strend, orig, |
231
|
|
|
|
|
|
(s == m), cx->sb_targ, NULL, |
232
|
|
|
|
|
|
(REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW))) |
233
|
|
|
|
|
|
{ |
234
|
1313419
|
|
|
|
|
SV *targ = cx->sb_targ; |
235
|
|
|
|
|
|
|
236
|
|
|
|
|
|
assert(cx->sb_strend >= s); |
237
|
1313419
|
100
|
|
|
|
if(cx->sb_strend > s) { |
238
|
822593
|
100
|
|
|
|
if (DO_UTF8(dstr) && !SvUTF8(targ)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
239
|
78
|
|
|
|
|
sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); |
240
|
|
|
|
|
|
else |
241
|
822515
|
|
|
|
|
sv_catpvn_nomg(dstr, s, cx->sb_strend - s); |
242
|
|
|
|
|
|
} |
243
|
1313419
|
100
|
|
|
|
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ |
244
|
30
|
|
|
|
|
cx->sb_rxtainted |= SUBST_TAINT_PAT; |
245
|
|
|
|
|
|
|
246
|
1313419
|
100
|
|
|
|
if (pm->op_pmflags & PMf_NONDESTRUCT) { |
247
|
1904
|
|
|
|
|
PUSHs(dstr); |
248
|
|
|
|
|
|
/* From here on down we're using the copy, and leaving the |
249
|
|
|
|
|
|
original untouched. */ |
250
|
|
|
|
|
|
targ = dstr; |
251
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
else { |
253
|
1311515
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(targ); |
254
|
1311511
|
100
|
|
|
|
if (isGV(targ)) Perl_croak_no_modify(); |
255
|
1311507
|
100
|
|
|
|
SvPV_free(targ); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
256
|
1311507
|
|
|
|
|
SvPV_set(targ, SvPVX(dstr)); |
257
|
1311507
|
|
|
|
|
SvCUR_set(targ, SvCUR(dstr)); |
258
|
1311507
|
|
|
|
|
SvLEN_set(targ, SvLEN(dstr)); |
259
|
1311507
|
100
|
|
|
|
if (DO_UTF8(dstr)) |
|
|
50
|
|
|
|
|
260
|
9026
|
|
|
|
|
SvUTF8_on(targ); |
261
|
1311507
|
|
|
|
|
SvPV_set(dstr, NULL); |
262
|
|
|
|
|
|
|
263
|
1311507
|
|
|
|
|
PL_tainted = 0; |
264
|
1311507
|
|
|
|
|
mPUSHi(saviters - 1); |
265
|
|
|
|
|
|
|
266
|
1311507
|
|
|
|
|
(void)SvPOK_only_UTF8(targ); |
267
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
269
|
|
|
|
|
|
/* update the taint state of various various variables in |
270
|
|
|
|
|
|
* preparation for final exit. |
271
|
|
|
|
|
|
* See "how taint works" above pp_subst() */ |
272
|
1313411
|
50
|
|
|
|
if (TAINTING_get) { |
273
|
0
|
0
|
|
|
|
if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || |
|
|
0
|
|
|
|
|
274
|
0
|
|
|
|
|
((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) |
275
|
|
|
|
|
|
== (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) |
276
|
|
|
|
|
|
) |
277
|
0
|
|
|
|
|
(RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ |
278
|
|
|
|
|
|
|
279
|
0
|
0
|
|
|
|
if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) |
280
|
0
|
0
|
|
|
|
&& (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) |
281
|
|
|
|
|
|
) |
282
|
0
|
0
|
|
|
|
SvTAINTED_on(TOPs); /* taint return value */ |
283
|
|
|
|
|
|
/* needed for mg_set below */ |
284
|
0
|
|
|
|
|
TAINT_set( |
285
|
|
|
|
|
|
cBOOL(cx->sb_rxtainted & |
286
|
|
|
|
|
|
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) |
287
|
|
|
|
|
|
); |
288
|
0
|
0
|
|
|
|
SvTAINT(TARG); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
289
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
/* PL_tainted must be correctly set for this mg_set */ |
291
|
1313411
|
50
|
|
|
|
SvSETMAGIC(TARG); |
292
|
1313411
|
|
|
|
|
TAINT_NOT; |
293
|
1313411
|
100
|
|
|
|
LEAVE_SCOPE(cx->sb_oldsave); |
294
|
1313411
|
|
|
|
|
POPSUBST(cx); |
295
|
1313411
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
296
|
1313411
|
|
|
|
|
RETURNOP(pm->op_next); |
297
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
298
|
|
|
|
|
|
} |
299
|
10337300
|
|
|
|
|
cx->sb_iters = saviters; |
300
|
|
|
|
|
|
} |
301
|
11667184
|
100
|
|
|
|
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { |
|
|
100
|
|
|
|
|
302
|
|
|
|
|
|
m = s; |
303
|
|
|
|
|
|
s = orig; |
304
|
|
|
|
|
|
assert(!RX_SUBOFFSET(rx)); |
305
|
6670
|
|
|
|
|
cx->sb_orig = orig = RX_SUBBEG(rx); |
306
|
6670
|
|
|
|
|
s = orig + (m - s); |
307
|
6670
|
|
|
|
|
cx->sb_strend = s + (cx->sb_strend - m); |
308
|
|
|
|
|
|
} |
309
|
11650727
|
|
|
|
|
cx->sb_m = m = RX_OFFS(rx)[0].start + orig; |
310
|
11650727
|
100
|
|
|
|
if (m > s) { |
311
|
726136
|
100
|
|
|
|
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
312
|
6
|
|
|
|
|
sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv); |
313
|
|
|
|
|
|
else |
314
|
726130
|
|
|
|
|
sv_catpvn_nomg(dstr, s, m-s); |
315
|
|
|
|
|
|
} |
316
|
11650727
|
|
|
|
|
cx->sb_s = RX_OFFS(rx)[0].end + orig; |
317
|
|
|
|
|
|
{ /* Update the pos() information. */ |
318
|
|
|
|
|
|
SV * const sv |
319
|
11650727
|
100
|
|
|
|
= (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; |
320
|
|
|
|
|
|
MAGIC *mg; |
321
|
11650727
|
100
|
|
|
|
if (!(mg = mg_find_mglob(sv))) { |
322
|
729267
|
|
|
|
|
mg = sv_magicext_mglob(sv); |
323
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
assert(SvPOK(dstr)); |
325
|
11650727
|
100
|
|
|
|
MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
326
|
|
|
|
|
|
} |
327
|
11650727
|
100
|
|
|
|
if (old != rx) |
328
|
|
|
|
|
|
(void)ReREFCNT_inc(rx); |
329
|
|
|
|
|
|
/* update the taint state of various various variables in preparation |
330
|
|
|
|
|
|
* for calling the code block. |
331
|
|
|
|
|
|
* See "how taint works" above pp_subst() */ |
332
|
11650727
|
50
|
|
|
|
if (TAINTING_get) { |
333
|
0
|
0
|
|
|
|
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ |
334
|
0
|
|
|
|
|
cx->sb_rxtainted |= SUBST_TAINT_PAT; |
335
|
|
|
|
|
|
|
336
|
0
|
0
|
|
|
|
if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || |
|
|
0
|
|
|
|
|
337
|
0
|
|
|
|
|
((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) |
338
|
|
|
|
|
|
== (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) |
339
|
|
|
|
|
|
) |
340
|
0
|
|
|
|
|
(RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ |
341
|
|
|
|
|
|
|
342
|
0
|
0
|
|
|
|
if (cx->sb_iters > 1 && (cx->sb_rxtainted & |
|
|
0
|
|
|
|
|
343
|
|
|
|
|
|
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) |
344
|
0
|
0
|
|
|
|
SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) |
|
|
0
|
|
|
|
|
345
|
|
|
|
|
|
? cx->sb_dstr : cx->sb_targ); |
346
|
0
|
|
|
|
|
TAINT_NOT; |
347
|
|
|
|
|
|
} |
348
|
11650727
|
|
|
|
|
rxres_save(&cx->sb_rxres, rx); |
349
|
11650727
|
|
|
|
|
PL_curpm = pm; |
350
|
12307612
|
|
|
|
|
RETURNOP(pm->op_pmstashstartu.op_pmreplstart); |
351
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
353
|
|
|
|
|
|
void |
354
|
12964154
|
|
|
|
|
Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) |
355
|
|
|
|
|
|
{ |
356
|
12964154
|
|
|
|
|
UV *p = (UV*)*rsp; |
357
|
|
|
|
|
|
U32 i; |
358
|
|
|
|
|
|
|
359
|
|
|
|
|
|
PERL_ARGS_ASSERT_RXRES_SAVE; |
360
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
361
|
|
|
|
|
|
|
362
|
18789338
|
100
|
|
|
|
if (!p || p[1] < RX_NPARENS(rx)) { |
|
|
50
|
|
|
|
|
363
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
364
|
1313427
|
|
|
|
|
i = 7 + (RX_NPARENS(rx)+1) * 2; |
365
|
|
|
|
|
|
#else |
366
|
|
|
|
|
|
i = 6 + (RX_NPARENS(rx)+1) * 2; |
367
|
|
|
|
|
|
#endif |
368
|
1313427
|
50
|
|
|
|
if (!p) |
369
|
1313427
|
50
|
|
|
|
Newx(p, i, UV); |
370
|
|
|
|
|
|
else |
371
|
0
|
0
|
|
|
|
Renew(p, i, UV); |
372
|
1313427
|
|
|
|
|
*rsp = (void*)p; |
373
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
375
|
|
|
|
|
|
/* what (if anything) to free on croak */ |
376
|
12983946
|
100
|
|
|
|
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); |
377
|
12964154
|
|
|
|
|
RX_MATCH_COPIED_off(rx); |
378
|
12964154
|
|
|
|
|
*p++ = RX_NPARENS(rx); |
379
|
|
|
|
|
|
|
380
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
381
|
12964154
|
|
|
|
|
*p++ = PTR2UV(RX_SAVED_COPY(rx)); |
382
|
12964154
|
|
|
|
|
RX_SAVED_COPY(rx) = NULL; |
383
|
|
|
|
|
|
#endif |
384
|
|
|
|
|
|
|
385
|
12964154
|
|
|
|
|
*p++ = PTR2UV(RX_SUBBEG(rx)); |
386
|
12964154
|
|
|
|
|
*p++ = (UV)RX_SUBLEN(rx); |
387
|
12964154
|
|
|
|
|
*p++ = (UV)RX_SUBOFFSET(rx); |
388
|
12964154
|
|
|
|
|
*p++ = (UV)RX_SUBCOFFSET(rx); |
389
|
60793705
|
100
|
|
|
|
for (i = 0; i <= RX_NPARENS(rx); ++i) { |
390
|
27565940
|
|
|
|
|
*p++ = (UV)RX_OFFS(rx)[i].start; |
391
|
27565940
|
|
|
|
|
*p++ = (UV)RX_OFFS(rx)[i].end; |
392
|
|
|
|
|
|
} |
393
|
12964154
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
395
|
|
|
|
|
|
static void |
396
|
12964146
|
|
|
|
|
S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) |
397
|
|
|
|
|
|
{ |
398
|
12964146
|
|
|
|
|
UV *p = (UV*)*rsp; |
399
|
|
|
|
|
|
U32 i; |
400
|
|
|
|
|
|
|
401
|
|
|
|
|
|
PERL_ARGS_ASSERT_RXRES_RESTORE; |
402
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
403
|
|
|
|
|
|
|
404
|
19445884
|
100
|
|
|
|
RX_MATCH_COPY_FREE(rx); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
405
|
19445860
|
100
|
|
|
|
RX_MATCH_COPIED_set(rx, *p); |
406
|
12964146
|
|
|
|
|
*p++ = 0; |
407
|
12964146
|
|
|
|
|
RX_NPARENS(rx) = *p++; |
408
|
|
|
|
|
|
|
409
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
410
|
12964146
|
100
|
|
|
|
if (RX_SAVED_COPY(rx)) |
411
|
24
|
|
|
|
|
SvREFCNT_dec (RX_SAVED_COPY(rx)); |
412
|
12964146
|
|
|
|
|
RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); |
413
|
12964146
|
|
|
|
|
*p++ = 0; |
414
|
|
|
|
|
|
#endif |
415
|
|
|
|
|
|
|
416
|
12964146
|
|
|
|
|
RX_SUBBEG(rx) = INT2PTR(char*,*p++); |
417
|
12964146
|
|
|
|
|
RX_SUBLEN(rx) = (I32)(*p++); |
418
|
12964146
|
|
|
|
|
RX_SUBOFFSET(rx) = (I32)*p++; |
419
|
12964146
|
|
|
|
|
RX_SUBCOFFSET(rx) = (I32)*p++; |
420
|
60793675
|
100
|
|
|
|
for (i = 0; i <= RX_NPARENS(rx); ++i) { |
421
|
27565928
|
|
|
|
|
RX_OFFS(rx)[i].start = (I32)(*p++); |
422
|
27565928
|
|
|
|
|
RX_OFFS(rx)[i].end = (I32)(*p++); |
423
|
|
|
|
|
|
} |
424
|
12964146
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
426
|
|
|
|
|
|
static void |
427
|
1313427
|
|
|
|
|
S_rxres_free(pTHX_ void **rsp) |
428
|
|
|
|
|
|
{ |
429
|
1313427
|
|
|
|
|
UV * const p = (UV*)*rsp; |
430
|
|
|
|
|
|
|
431
|
|
|
|
|
|
PERL_ARGS_ASSERT_RXRES_FREE; |
432
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
433
|
|
|
|
|
|
|
434
|
1313427
|
50
|
|
|
|
if (p) { |
435
|
1313427
|
|
|
|
|
void *tmp = INT2PTR(char*,*p); |
436
|
|
|
|
|
|
#ifdef PERL_POISON |
437
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
438
|
|
|
|
|
|
U32 i = 9 + p[1] * 2; |
439
|
|
|
|
|
|
#else |
440
|
|
|
|
|
|
U32 i = 8 + p[1] * 2; |
441
|
|
|
|
|
|
#endif |
442
|
|
|
|
|
|
#endif |
443
|
|
|
|
|
|
|
444
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
445
|
1313427
|
|
|
|
|
SvREFCNT_dec (INT2PTR(SV*,p[2])); |
446
|
|
|
|
|
|
#endif |
447
|
|
|
|
|
|
#ifdef PERL_POISON |
448
|
|
|
|
|
|
PoisonFree(p, i, sizeof(UV)); |
449
|
|
|
|
|
|
#endif |
450
|
|
|
|
|
|
|
451
|
1313427
|
|
|
|
|
Safefree(tmp); |
452
|
1313427
|
|
|
|
|
Safefree(p); |
453
|
1313427
|
|
|
|
|
*rsp = NULL; |
454
|
|
|
|
|
|
} |
455
|
1313427
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
457
|
|
|
|
|
|
#define FORM_NUM_BLANK (1<<30) |
458
|
|
|
|
|
|
#define FORM_NUM_POINT (1<<29) |
459
|
|
|
|
|
|
|
460
|
3336
|
|
|
|
|
PP(pp_formline) |
461
|
|
|
|
|
|
{ |
462
|
3336
|
|
|
|
|
dVAR; dSP; dMARK; dORIGMARK; |
463
|
3336
|
|
|
|
|
SV * const tmpForm = *++MARK; |
464
|
|
|
|
|
|
SV *formsv; /* contains text of original format */ |
465
|
|
|
|
|
|
U32 *fpc; /* format ops program counter */ |
466
|
|
|
|
|
|
char *t; /* current append position in target string */ |
467
|
|
|
|
|
|
const char *f; /* current position in format string */ |
468
|
|
|
|
|
|
I32 arg; |
469
|
|
|
|
|
|
SV *sv = NULL; /* current item */ |
470
|
|
|
|
|
|
const char *item = NULL;/* string value of current item */ |
471
|
3336
|
|
|
|
|
I32 itemsize = 0; /* length of current item, possibly truncated */ |
472
|
|
|
|
|
|
I32 fieldsize = 0; /* width of current field */ |
473
|
|
|
|
|
|
I32 lines = 0; /* number of lines that have been output */ |
474
|
3336
|
|
|
|
|
bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */ |
475
|
|
|
|
|
|
const char *chophere = NULL; /* where to chop current item */ |
476
|
|
|
|
|
|
STRLEN linemark = 0; /* pos of start of line in output */ |
477
|
|
|
|
|
|
NV value; |
478
|
|
|
|
|
|
bool gotsome = FALSE; /* seen at least one non-blank item on this line */ |
479
|
|
|
|
|
|
STRLEN len; |
480
|
|
|
|
|
|
STRLEN linemax; /* estimate of output size in bytes */ |
481
|
|
|
|
|
|
bool item_is_utf8 = FALSE; |
482
|
|
|
|
|
|
bool targ_is_utf8 = FALSE; |
483
|
|
|
|
|
|
const char *fmt; |
484
|
|
|
|
|
|
MAGIC *mg = NULL; |
485
|
|
|
|
|
|
U8 *source; /* source of bytes to append */ |
486
|
|
|
|
|
|
STRLEN to_copy; /* how may bytes to append */ |
487
|
|
|
|
|
|
char trans; /* what chars to translate */ |
488
|
|
|
|
|
|
|
489
|
3336
|
|
|
|
|
mg = doparseform(tmpForm); |
490
|
|
|
|
|
|
|
491
|
3330
|
|
|
|
|
fpc = (U32*)mg->mg_ptr; |
492
|
|
|
|
|
|
/* the actual string the format was compiled from. |
493
|
|
|
|
|
|
* with overload etc, this may not match tmpForm */ |
494
|
3330
|
|
|
|
|
formsv = mg->mg_obj; |
495
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
497
|
3330
|
100
|
|
|
|
SvPV_force(PL_formtarget, len); |
498
|
3330
|
50
|
|
|
|
if (SvTAINTED(tmpForm) || SvTAINTED(formsv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
499
|
0
|
0
|
|
|
|
SvTAINTED_on(PL_formtarget); |
500
|
3330
|
100
|
|
|
|
if (DO_UTF8(PL_formtarget)) |
|
|
50
|
|
|
|
|
501
|
|
|
|
|
|
targ_is_utf8 = TRUE; |
502
|
3330
|
50
|
|
|
|
linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); |
503
|
3330
|
50
|
|
|
|
t = SvGROW(PL_formtarget, len + linemax + 1); |
|
|
100
|
|
|
|
|
504
|
|
|
|
|
|
/* XXX from now onwards, SvCUR(PL_formtarget) is invalid */ |
505
|
3330
|
|
|
|
|
t += len; |
506
|
3330
|
50
|
|
|
|
f = SvPV_const(formsv, len); |
507
|
|
|
|
|
|
|
508
|
|
|
|
|
|
for (;;) { |
509
|
|
|
|
|
|
DEBUG_f( { |
510
|
|
|
|
|
|
const char *name = "???"; |
511
|
|
|
|
|
|
arg = -1; |
512
|
|
|
|
|
|
switch (*fpc) { |
513
|
|
|
|
|
|
case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; |
514
|
|
|
|
|
|
case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; |
515
|
|
|
|
|
|
case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; |
516
|
|
|
|
|
|
case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; |
517
|
|
|
|
|
|
case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; |
518
|
|
|
|
|
|
|
519
|
|
|
|
|
|
case FF_CHECKNL: name = "CHECKNL"; break; |
520
|
|
|
|
|
|
case FF_CHECKCHOP: name = "CHECKCHOP"; break; |
521
|
|
|
|
|
|
case FF_SPACE: name = "SPACE"; break; |
522
|
|
|
|
|
|
case FF_HALFSPACE: name = "HALFSPACE"; break; |
523
|
|
|
|
|
|
case FF_ITEM: name = "ITEM"; break; |
524
|
|
|
|
|
|
case FF_CHOP: name = "CHOP"; break; |
525
|
|
|
|
|
|
case FF_LINEGLOB: name = "LINEGLOB"; break; |
526
|
|
|
|
|
|
case FF_NEWLINE: name = "NEWLINE"; break; |
527
|
|
|
|
|
|
case FF_MORE: name = "MORE"; break; |
528
|
|
|
|
|
|
case FF_LINEMARK: name = "LINEMARK"; break; |
529
|
|
|
|
|
|
case FF_END: name = "END"; break; |
530
|
|
|
|
|
|
case FF_0DECIMAL: name = "0DECIMAL"; break; |
531
|
|
|
|
|
|
case FF_LINESNGL: name = "LINESNGL"; break; |
532
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
if (arg >= 0) |
534
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); |
535
|
|
|
|
|
|
else |
536
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "%-16s\n", name); |
537
|
|
|
|
|
|
} ); |
538
|
39834
|
|
|
|
|
switch (*fpc++) { |
539
|
|
|
|
|
|
case FF_LINEMARK: |
540
|
3404
|
|
|
|
|
linemark = t - SvPVX(PL_formtarget); |
541
|
3404
|
|
|
|
|
lines++; |
542
|
|
|
|
|
|
gotsome = FALSE; |
543
|
3404
|
|
|
|
|
break; |
544
|
|
|
|
|
|
|
545
|
|
|
|
|
|
case FF_LITERAL: |
546
|
5602
|
|
|
|
|
to_copy = *fpc++; |
547
|
|
|
|
|
|
source = (U8 *)f; |
548
|
5602
|
|
|
|
|
f += to_copy; |
549
|
|
|
|
|
|
trans = '~'; |
550
|
5602
|
100
|
|
|
|
item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
551
|
5602
|
|
|
|
|
goto append; |
552
|
|
|
|
|
|
|
553
|
|
|
|
|
|
case FF_SKIP: |
554
|
2198
|
|
|
|
|
f += *fpc++; |
555
|
2198
|
|
|
|
|
break; |
556
|
|
|
|
|
|
|
557
|
|
|
|
|
|
case FF_FETCH: |
558
|
5682
|
|
|
|
|
arg = *fpc++; |
559
|
5682
|
|
|
|
|
f += arg; |
560
|
|
|
|
|
|
fieldsize = arg; |
561
|
|
|
|
|
|
|
562
|
5682
|
100
|
|
|
|
if (MARK < SP) |
563
|
5668
|
|
|
|
|
sv = *++MARK; |
564
|
|
|
|
|
|
else { |
565
|
|
|
|
|
|
sv = &PL_sv_no; |
566
|
14
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); |
567
|
|
|
|
|
|
} |
568
|
5682
|
100
|
|
|
|
if (SvTAINTED(sv)) |
|
|
50
|
|
|
|
|
569
|
0
|
0
|
|
|
|
SvTAINTED_on(PL_formtarget); |
570
|
|
|
|
|
|
break; |
571
|
|
|
|
|
|
|
572
|
|
|
|
|
|
case FF_CHECKNL: |
573
|
|
|
|
|
|
{ |
574
|
|
|
|
|
|
const char *send; |
575
|
592
|
100
|
|
|
|
const char *s = item = SvPV_const(sv, len); |
576
|
592
|
|
|
|
|
itemsize = len; |
577
|
592
|
100
|
|
|
|
if (DO_UTF8(sv)) { |
|
|
50
|
|
|
|
|
578
|
4
|
|
|
|
|
itemsize = sv_len_utf8(sv); |
579
|
4
|
50
|
|
|
|
if (itemsize != (I32)len) { |
580
|
|
|
|
|
|
I32 itembytes; |
581
|
4
|
50
|
|
|
|
if (itemsize > fieldsize) { |
582
|
0
|
|
|
|
|
itemsize = fieldsize; |
583
|
0
|
|
|
|
|
itembytes = itemsize; |
584
|
0
|
|
|
|
|
sv_pos_u2b(sv, &itembytes, 0); |
585
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
else |
587
|
4
|
|
|
|
|
itembytes = len; |
588
|
4
|
|
|
|
|
send = chophere = s + itembytes; |
589
|
14
|
100
|
|
|
|
while (s < send) { |
590
|
8
|
50
|
|
|
|
if (! isCNTRL(*s)) |
591
|
|
|
|
|
|
gotsome = TRUE; |
592
|
0
|
0
|
|
|
|
else if (*s == '\n') |
593
|
|
|
|
|
|
break; |
594
|
8
|
|
|
|
|
s++; |
595
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
item_is_utf8 = TRUE; |
597
|
4
|
|
|
|
|
itemsize = s - item; |
598
|
4
|
|
|
|
|
sv_pos_b2u(sv, &itemsize); |
599
|
18254
|
|
|
|
|
break; |
600
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
item_is_utf8 = FALSE; |
603
|
588
|
100
|
|
|
|
if (itemsize > fieldsize) |
604
|
72
|
|
|
|
|
itemsize = fieldsize; |
605
|
588
|
|
|
|
|
send = chophere = s + itemsize; |
606
|
2412
|
100
|
|
|
|
while (s < send) { |
607
|
1542
|
100
|
|
|
|
if (! isCNTRL(*s)) |
608
|
|
|
|
|
|
gotsome = TRUE; |
609
|
12
|
50
|
|
|
|
else if (*s == '\n') |
610
|
|
|
|
|
|
break; |
611
|
1530
|
|
|
|
|
s++; |
612
|
|
|
|
|
|
} |
613
|
588
|
|
|
|
|
itemsize = s - item; |
614
|
588
|
|
|
|
|
break; |
615
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
617
|
|
|
|
|
|
case FF_CHECKCHOP: |
618
|
|
|
|
|
|
{ |
619
|
3072
|
100
|
|
|
|
const char *s = item = SvPV_const(sv, len); |
620
|
3072
|
|
|
|
|
itemsize = len; |
621
|
3072
|
50
|
|
|
|
if (DO_UTF8(sv)) { |
|
|
0
|
|
|
|
|
622
|
0
|
|
|
|
|
itemsize = sv_len_utf8(sv); |
623
|
0
|
0
|
|
|
|
if (itemsize != (I32)len) { |
624
|
|
|
|
|
|
I32 itembytes; |
625
|
0
|
0
|
|
|
|
if (itemsize <= fieldsize) { |
626
|
0
|
|
|
|
|
const char *send = chophere = s + itemsize; |
627
|
0
|
0
|
|
|
|
while (s < send) { |
628
|
0
|
0
|
|
|
|
if (*s == '\r') { |
629
|
0
|
|
|
|
|
itemsize = s - item; |
630
|
|
|
|
|
|
chophere = s; |
631
|
0
|
|
|
|
|
break; |
632
|
|
|
|
|
|
} |
633
|
0
|
0
|
|
|
|
if (! isCNTRL(*s)) |
634
|
|
|
|
|
|
gotsome = TRUE; |
635
|
0
|
|
|
|
|
s++; |
636
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
else { |
639
|
|
|
|
|
|
const char *send; |
640
|
0
|
|
|
|
|
itemsize = fieldsize; |
641
|
0
|
|
|
|
|
itembytes = itemsize; |
642
|
0
|
|
|
|
|
sv_pos_u2b(sv, &itembytes, 0); |
643
|
0
|
|
|
|
|
send = chophere = s + itembytes; |
644
|
0
|
0
|
|
|
|
while (s < send || (s == send && isSPACE(*s))) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
645
|
0
|
0
|
|
|
|
if (isSPACE(*s)) { |
646
|
0
|
0
|
|
|
|
if (chopspace) |
647
|
|
|
|
|
|
chophere = s; |
648
|
0
|
0
|
|
|
|
if (*s == '\r') |
649
|
|
|
|
|
|
break; |
650
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
else { |
652
|
0
|
0
|
|
|
|
if (! isCNTRL(*s)) |
653
|
|
|
|
|
|
gotsome = TRUE; |
654
|
0
|
0
|
|
|
|
if (strchr(PL_chopset, *s)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
655
|
0
|
|
|
|
|
chophere = s + 1; |
656
|
|
|
|
|
|
} |
657
|
0
|
|
|
|
|
s++; |
658
|
|
|
|
|
|
} |
659
|
0
|
|
|
|
|
itemsize = chophere - item; |
660
|
0
|
|
|
|
|
sv_pos_b2u(sv, &itemsize); |
661
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
item_is_utf8 = TRUE; |
663
|
|
|
|
|
|
break; |
664
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
item_is_utf8 = FALSE; |
667
|
3072
|
100
|
|
|
|
if (itemsize <= fieldsize) { |
668
|
2858
|
|
|
|
|
const char *const send = chophere = s + itemsize; |
669
|
15805
|
100
|
|
|
|
while (s < send) { |
670
|
11522
|
100
|
|
|
|
if (*s == '\r') { |
671
|
4
|
|
|
|
|
itemsize = s - item; |
672
|
|
|
|
|
|
chophere = s; |
673
|
4
|
|
|
|
|
break; |
674
|
|
|
|
|
|
} |
675
|
11518
|
50
|
|
|
|
if (! isCNTRL(*s)) |
676
|
|
|
|
|
|
gotsome = TRUE; |
677
|
11518
|
|
|
|
|
s++; |
678
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
else { |
681
|
|
|
|
|
|
const char *send; |
682
|
214
|
|
|
|
|
itemsize = fieldsize; |
683
|
214
|
|
|
|
|
send = chophere = s + itemsize; |
684
|
7987
|
100
|
|
|
|
while (s < send || (s == send && isSPACE(*s))) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
685
|
7666
|
100
|
|
|
|
if (isSPACE(*s)) { |
686
|
1074
|
50
|
|
|
|
if (chopspace) |
687
|
|
|
|
|
|
chophere = s; |
688
|
1074
|
50
|
|
|
|
if (*s == '\r') |
689
|
|
|
|
|
|
break; |
690
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
else { |
692
|
6592
|
50
|
|
|
|
if (! isCNTRL(*s)) |
693
|
|
|
|
|
|
gotsome = TRUE; |
694
|
6592
|
50
|
|
|
|
if (strchr(PL_chopset, *s)) |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
695
|
26
|
|
|
|
|
chophere = s + 1; |
696
|
|
|
|
|
|
} |
697
|
7666
|
|
|
|
|
s++; |
698
|
|
|
|
|
|
} |
699
|
214
|
|
|
|
|
itemsize = chophere - item; |
700
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
break; |
702
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
704
|
|
|
|
|
|
case FF_SPACE: |
705
|
2266
|
|
|
|
|
arg = fieldsize - itemsize; |
706
|
2266
|
100
|
|
|
|
if (arg) { |
707
|
|
|
|
|
|
fieldsize -= arg; |
708
|
15004
|
100
|
|
|
|
while (arg-- > 0) |
709
|
12816
|
|
|
|
|
*t++ = ' '; |
710
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
break; |
712
|
|
|
|
|
|
|
713
|
|
|
|
|
|
case FF_HALFSPACE: |
714
|
240
|
|
|
|
|
arg = fieldsize - itemsize; |
715
|
240
|
50
|
|
|
|
if (arg) { |
716
|
240
|
|
|
|
|
arg /= 2; |
717
|
240
|
|
|
|
|
fieldsize -= arg; |
718
|
636
|
100
|
|
|
|
while (arg-- > 0) |
719
|
276
|
|
|
|
|
*t++ = ' '; |
720
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
break; |
722
|
|
|
|
|
|
|
723
|
|
|
|
|
|
case FF_ITEM: |
724
|
3664
|
|
|
|
|
to_copy = itemsize; |
725
|
|
|
|
|
|
source = (U8 *)item; |
726
|
|
|
|
|
|
trans = 1; |
727
|
3664
|
100
|
|
|
|
if (item_is_utf8) { |
728
|
|
|
|
|
|
/* convert to_copy from chars to bytes */ |
729
|
|
|
|
|
|
U8 *s = source; |
730
|
8
|
100
|
|
|
|
while (to_copy--) |
731
|
4
|
|
|
|
|
s += UTF8SKIP(s); |
732
|
4
|
|
|
|
|
to_copy = s - source; |
733
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
goto append; |
735
|
|
|
|
|
|
|
736
|
|
|
|
|
|
case FF_CHOP: |
737
|
|
|
|
|
|
{ |
738
|
|
|
|
|
|
const char *s = chophere; |
739
|
4544
|
100
|
|
|
|
if (chopspace) { |
740
|
3296
|
100
|
|
|
|
while (isSPACE(*s)) |
741
|
224
|
|
|
|
|
s++; |
742
|
|
|
|
|
|
} |
743
|
4544
|
|
|
|
|
sv_chop(sv,s); |
744
|
5280
|
100
|
|
|
|
SvSETMAGIC(sv); |
745
|
|
|
|
|
|
break; |
746
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
748
|
|
|
|
|
|
case FF_LINESNGL: |
749
|
|
|
|
|
|
chopspace = 0; |
750
|
|
|
|
|
|
case FF_LINEGLOB: |
751
|
|
|
|
|
|
{ |
752
|
1882
|
|
|
|
|
const bool oneline = fpc[-1] == FF_LINESNGL; |
753
|
1882
|
100
|
|
|
|
const char *s = item = SvPV_const(sv, len); |
754
|
1882
|
|
|
|
|
const char *const send = s + len; |
755
|
|
|
|
|
|
|
756
|
1882
|
100
|
|
|
|
item_is_utf8 = DO_UTF8(sv); |
|
|
50
|
|
|
|
|
757
|
1882
|
100
|
|
|
|
if (!len) |
758
|
|
|
|
|
|
break; |
759
|
|
|
|
|
|
trans = 0; |
760
|
|
|
|
|
|
gotsome = TRUE; |
761
|
1680
|
|
|
|
|
chophere = s + len; |
762
|
|
|
|
|
|
source = (U8 *) s; |
763
|
1680
|
|
|
|
|
to_copy = len; |
764
|
11230
|
100
|
|
|
|
while (s < send) { |
765
|
9194
|
100
|
|
|
|
if (*s++ == '\n') { |
766
|
990
|
100
|
|
|
|
if (oneline) { |
767
|
484
|
|
|
|
|
to_copy = s - SvPVX_const(sv) - 1; |
768
|
|
|
|
|
|
chophere = s; |
769
|
484
|
|
|
|
|
break; |
770
|
|
|
|
|
|
} else { |
771
|
506
|
100
|
|
|
|
if (s == send) { |
772
|
250
|
|
|
|
|
to_copy--; |
773
|
|
|
|
|
|
} else |
774
|
4483
|
|
|
|
|
lines++; |
775
|
|
|
|
|
|
} |
776
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
} |
778
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
780
|
|
|
|
|
|
append: |
781
|
|
|
|
|
|
/* append to_copy bytes from source to PL_formstring. |
782
|
|
|
|
|
|
* item_is_utf8 implies source is utf8. |
783
|
|
|
|
|
|
* if trans, translate certain characters during the copy */ |
784
|
|
|
|
|
|
{ |
785
|
|
|
|
|
|
U8 *tmp = NULL; |
786
|
|
|
|
|
|
STRLEN grow = 0; |
787
|
|
|
|
|
|
|
788
|
10946
|
|
|
|
|
SvCUR_set(PL_formtarget, |
789
|
|
|
|
|
|
t - SvPVX_const(PL_formtarget)); |
790
|
|
|
|
|
|
|
791
|
10946
|
100
|
|
|
|
if (targ_is_utf8 && !item_is_utf8) { |
|
|
100
|
|
|
|
|
792
|
828
|
|
|
|
|
source = tmp = bytes_to_utf8(source, &to_copy); |
793
|
|
|
|
|
|
} else { |
794
|
10118
|
100
|
|
|
|
if (item_is_utf8 && !targ_is_utf8) { |
|
|
100
|
|
|
|
|
795
|
|
|
|
|
|
U8 *s; |
796
|
|
|
|
|
|
/* Upgrade targ to UTF8, and then we reduce it to |
797
|
|
|
|
|
|
a problem we have a simple solution for. |
798
|
|
|
|
|
|
Don't need get magic. */ |
799
|
406
|
|
|
|
|
sv_utf8_upgrade_nomg(PL_formtarget); |
800
|
|
|
|
|
|
targ_is_utf8 = TRUE; |
801
|
|
|
|
|
|
/* re-calculate linemark */ |
802
|
406
|
|
|
|
|
s = (U8*)SvPVX(PL_formtarget); |
803
|
|
|
|
|
|
/* the bytes we initially allocated to append the |
804
|
|
|
|
|
|
* whole line may have been gobbled up during the |
805
|
|
|
|
|
|
* upgrade, so allocate a whole new line's worth |
806
|
|
|
|
|
|
* for safety */ |
807
|
|
|
|
|
|
grow = linemax; |
808
|
621
|
100
|
|
|
|
while (linemark--) |
809
|
12
|
|
|
|
|
s += UTF8SKIP(s); |
810
|
406
|
|
|
|
|
linemark = s - (U8*)SvPVX(PL_formtarget); |
811
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
/* Easy. They agree. */ |
813
|
|
|
|
|
|
assert (item_is_utf8 == targ_is_utf8); |
814
|
|
|
|
|
|
} |
815
|
10946
|
100
|
|
|
|
if (!trans) |
816
|
|
|
|
|
|
/* @* and ^* are the only things that can exceed |
817
|
|
|
|
|
|
* the linemax, so grow by the output size, plus |
818
|
|
|
|
|
|
* a whole new form's worth in case of any further |
819
|
|
|
|
|
|
* output */ |
820
|
1680
|
|
|
|
|
grow = linemax + to_copy; |
821
|
10946
|
100
|
|
|
|
if (grow) |
822
|
1686
|
50
|
|
|
|
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1); |
|
|
100
|
|
|
|
|
823
|
10946
|
|
|
|
|
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); |
824
|
|
|
|
|
|
|
825
|
10946
|
|
|
|
|
Copy(source, t, to_copy, char); |
826
|
10946
|
100
|
|
|
|
if (trans) { |
827
|
|
|
|
|
|
/* blank out ~ or control chars, depending on trans. |
828
|
|
|
|
|
|
* works on bytes not chars, so relies on not |
829
|
|
|
|
|
|
* matching utf8 continuation bytes */ |
830
|
|
|
|
|
|
U8 *s = (U8*)t; |
831
|
9266
|
|
|
|
|
U8 *send = s + to_copy; |
832
|
306177
|
100
|
|
|
|
while (s < send) { |
833
|
292278
|
|
|
|
|
const int ch = *s; |
834
|
292278
|
100
|
|
|
|
if (trans == '~' ? (ch == '~') : isCNTRL(ch)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
835
|
752
|
|
|
|
|
*s = ' '; |
836
|
292278
|
|
|
|
|
s++; |
837
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
|
840
|
10946
|
|
|
|
|
t += to_copy; |
841
|
10946
|
|
|
|
|
SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); |
842
|
10946
|
100
|
|
|
|
if (tmp) |
843
|
828
|
|
|
|
|
Safefree(tmp); |
844
|
|
|
|
|
|
break; |
845
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
847
|
|
|
|
|
|
case FF_0DECIMAL: |
848
|
56
|
|
|
|
|
arg = *fpc++; |
849
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
850
|
|
|
|
|
|
fmt = (const char *) |
851
|
|
|
|
|
|
((arg & FORM_NUM_POINT) ? |
852
|
|
|
|
|
|
"%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); |
853
|
|
|
|
|
|
#else |
854
|
56
|
100
|
|
|
|
fmt = (const char *) |
855
|
56
|
|
|
|
|
((arg & FORM_NUM_POINT) ? |
856
|
|
|
|
|
|
"%#0*.*f" : "%0*.*f"); |
857
|
|
|
|
|
|
#endif |
858
|
56
|
|
|
|
|
goto ff_dec; |
859
|
|
|
|
|
|
case FF_DECIMAL: |
860
|
80
|
|
|
|
|
arg = *fpc++; |
861
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
862
|
|
|
|
|
|
fmt = (const char *) |
863
|
|
|
|
|
|
((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); |
864
|
|
|
|
|
|
#else |
865
|
80
|
100
|
|
|
|
fmt = (const char *) |
866
|
80
|
|
|
|
|
((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f"); |
867
|
|
|
|
|
|
#endif |
868
|
|
|
|
|
|
ff_dec: |
869
|
|
|
|
|
|
/* If the field is marked with ^ and the value is undefined, |
870
|
|
|
|
|
|
blank it out. */ |
871
|
136
|
100
|
|
|
|
if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
872
|
|
|
|
|
|
arg = fieldsize; |
873
|
40
|
100
|
|
|
|
while (arg--) |
874
|
32
|
|
|
|
|
*t++ = ' '; |
875
|
|
|
|
|
|
break; |
876
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
gotsome = TRUE; |
878
|
128
|
100
|
|
|
|
value = SvNV(sv); |
879
|
|
|
|
|
|
/* overflow evidence */ |
880
|
128
|
100
|
|
|
|
if (num_overflow(value, fieldsize, arg)) { |
881
|
|
|
|
|
|
arg = fieldsize; |
882
|
224
|
100
|
|
|
|
while (arg--) |
883
|
184
|
|
|
|
|
*t++ = '#'; |
884
|
|
|
|
|
|
break; |
885
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
/* Formats aren't yet marked for locales, so assume "yes". */ |
887
|
|
|
|
|
|
{ |
888
|
88
|
50
|
|
|
|
STORE_NUMERIC_STANDARD_SET_LOCAL(); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
889
|
88
|
|
|
|
|
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); |
890
|
132
|
50
|
|
|
|
my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value); |
|
|
50
|
|
|
|
|
891
|
88
|
50
|
|
|
|
RESTORE_NUMERIC_STANDARD(); |
892
|
|
|
|
|
|
} |
893
|
88
|
|
|
|
|
t += fieldsize; |
894
|
88
|
|
|
|
|
break; |
895
|
|
|
|
|
|
|
896
|
|
|
|
|
|
case FF_NEWLINE: |
897
|
2444
|
|
|
|
|
f++; |
898
|
5883
|
100
|
|
|
|
while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ; |
|
|
100
|
|
|
|
|
899
|
|
|
|
|
|
t++; |
900
|
2444
|
|
|
|
|
*t++ = '\n'; |
901
|
2444
|
|
|
|
|
break; |
902
|
|
|
|
|
|
|
903
|
|
|
|
|
|
case FF_BLANK: |
904
|
1566
|
|
|
|
|
arg = *fpc++; |
905
|
1566
|
100
|
|
|
|
if (gotsome) { |
906
|
926
|
100
|
|
|
|
if (arg) { /* repeat until fields exhausted? */ |
907
|
796
|
|
|
|
|
fpc--; |
908
|
796
|
|
|
|
|
goto end; |
909
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
} |
911
|
|
|
|
|
|
else { |
912
|
640
|
|
|
|
|
t = SvPVX(PL_formtarget) + linemark; |
913
|
640
|
|
|
|
|
lines--; |
914
|
|
|
|
|
|
} |
915
|
|
|
|
|
|
break; |
916
|
|
|
|
|
|
|
917
|
|
|
|
|
|
case FF_MORE: |
918
|
|
|
|
|
|
{ |
919
|
|
|
|
|
|
const char *s = chophere; |
920
|
8
|
|
|
|
|
const char *send = item + len; |
921
|
8
|
50
|
|
|
|
if (chopspace) { |
922
|
24
|
100
|
|
|
|
while (isSPACE(*s) && (s < send)) |
923
|
16
|
|
|
|
|
s++; |
924
|
|
|
|
|
|
} |
925
|
8
|
100
|
|
|
|
if (s < send) { |
926
|
|
|
|
|
|
char *s1; |
927
|
4
|
|
|
|
|
arg = fieldsize - itemsize; |
928
|
4
|
50
|
|
|
|
if (arg) { |
929
|
|
|
|
|
|
fieldsize -= arg; |
930
|
12
|
100
|
|
|
|
while (arg-- > 0) |
931
|
8
|
|
|
|
|
*t++ = ' '; |
932
|
|
|
|
|
|
} |
933
|
4
|
|
|
|
|
s1 = t - 3; |
934
|
4
|
50
|
|
|
|
if (strnEQ(s1," ",3)) { |
935
|
0
|
0
|
|
|
|
while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) |
|
|
0
|
|
|
|
|
936
|
0
|
|
|
|
|
s1--; |
937
|
|
|
|
|
|
} |
938
|
4
|
|
|
|
|
*s1++ = '.'; |
939
|
4
|
|
|
|
|
*s1++ = '.'; |
940
|
4
|
|
|
|
|
*s1++ = '.'; |
941
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
break; |
943
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
case FF_END: |
945
|
|
|
|
|
|
end: |
946
|
|
|
|
|
|
assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget)); |
947
|
3330
|
|
|
|
|
*t = '\0'; |
948
|
3330
|
|
|
|
|
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); |
949
|
3330
|
100
|
|
|
|
if (targ_is_utf8) |
950
|
430
|
|
|
|
|
SvUTF8_on(PL_formtarget); |
951
|
3330
|
|
|
|
|
FmLINES(PL_formtarget) += lines; |
952
|
3330
|
|
|
|
|
SP = ORIGMARK; |
953
|
3330
|
100
|
|
|
|
if (fpc[-1] == FF_BLANK) |
954
|
796
|
|
|
|
|
RETURNOP(cLISTOP->op_first); |
955
|
|
|
|
|
|
else |
956
|
2932
|
|
|
|
|
RETPUSHYES; |
957
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
} |
959
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
961
|
16995643
|
|
|
|
|
PP(pp_grepstart) |
962
|
|
|
|
|
|
{ |
963
|
16995643
|
|
|
|
|
dVAR; dSP; |
964
|
|
|
|
|
|
SV *src; |
965
|
|
|
|
|
|
|
966
|
16995643
|
100
|
|
|
|
if (PL_stack_base + *PL_markstack_ptr == SP) { |
967
|
521310
|
|
|
|
|
(void)POPMARK; |
968
|
521310
|
100
|
|
|
|
if (GIMME_V == G_SCALAR) |
|
|
100
|
|
|
|
|
969
|
377608
|
50
|
|
|
|
mXPUSHi(0); |
970
|
521310
|
|
|
|
|
RETURNOP(PL_op->op_next->op_next); |
971
|
|
|
|
|
|
} |
972
|
16474333
|
|
|
|
|
PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; |
973
|
16474333
|
|
|
|
|
Perl_pp_pushmark(aTHX); /* push dst */ |
974
|
16474333
|
|
|
|
|
Perl_pp_pushmark(aTHX); /* push src */ |
975
|
16474333
|
|
|
|
|
ENTER_with_name("grep"); /* enter outer scope */ |
976
|
|
|
|
|
|
|
977
|
16474333
|
|
|
|
|
SAVETMPS; |
978
|
16474333
|
100
|
|
|
|
if (PL_op->op_private & OPpGREP_LEX) |
979
|
18
|
|
|
|
|
SAVESPTR(PAD_SVl(PL_op->op_targ)); |
980
|
|
|
|
|
|
else |
981
|
16474315
|
|
|
|
|
SAVE_DEFSV; |
982
|
16474333
|
|
|
|
|
ENTER_with_name("grep_item"); /* enter inner scope */ |
983
|
16474333
|
|
|
|
|
SAVEVPTR(PL_curpm); |
984
|
|
|
|
|
|
|
985
|
16474333
|
|
|
|
|
src = PL_stack_base[*PL_markstack_ptr]; |
986
|
16474333
|
100
|
|
|
|
if (SvPADTMP(src) && !IS_PADGV(src)) { |
987
|
3304
|
|
|
|
|
src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); |
988
|
3304
|
|
|
|
|
PL_tmps_floor++; |
989
|
|
|
|
|
|
} |
990
|
16474333
|
|
|
|
|
SvTEMP_off(src); |
991
|
16474333
|
100
|
|
|
|
if (PL_op->op_private & OPpGREP_LEX) |
992
|
18
|
|
|
|
|
PAD_SVl(PL_op->op_targ) = src; |
993
|
|
|
|
|
|
else |
994
|
32948630
|
|
|
|
|
DEFSV_set(src); |
995
|
|
|
|
|
|
|
996
|
16474333
|
|
|
|
|
PUTBACK; |
997
|
16474333
|
100
|
|
|
|
if (PL_op->op_type == OP_MAPSTART) |
998
|
2931075
|
|
|
|
|
Perl_pp_pushmark(aTHX); /* push top */ |
999
|
16734988
|
|
|
|
|
return ((LOGOP*)PL_op->op_next)->op_other; |
1000
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
1002
|
9057670
|
|
|
|
|
PP(pp_mapwhile) |
1003
|
|
|
|
|
|
{ |
1004
|
9057670
|
|
|
|
|
dVAR; dSP; |
1005
|
9057670
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
1006
|
9057670
|
|
|
|
|
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ |
1007
|
|
|
|
|
|
I32 count; |
1008
|
|
|
|
|
|
I32 shift; |
1009
|
|
|
|
|
|
SV** src; |
1010
|
|
|
|
|
|
SV** dst; |
1011
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
/* first, move source pointer to the next item in the source list */ |
1013
|
9057670
|
|
|
|
|
++PL_markstack_ptr[-1]; |
1014
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
/* if there are new items, push them into the destination list */ |
1016
|
9057670
|
100
|
|
|
|
if (items && gimme != G_VOID) { |
1017
|
|
|
|
|
|
/* might need to make room back there first */ |
1018
|
8793832
|
100
|
|
|
|
if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { |
|
|
100
|
|
|
|
|
1019
|
|
|
|
|
|
/* XXX this implementation is very pessimal because the stack |
1020
|
|
|
|
|
|
* is repeatedly extended for every set of items. Is possible |
1021
|
|
|
|
|
|
* to do this without any stack extension or copying at all |
1022
|
|
|
|
|
|
* by maintaining a separate list over which the map iterates |
1023
|
|
|
|
|
|
* (like foreach does). --gsar */ |
1024
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
/* everything in the stack after the destination list moves |
1026
|
|
|
|
|
|
* towards the end the stack by the amount of room needed */ |
1027
|
160124
|
|
|
|
|
shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); |
1028
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
/* items to shift up (accounting for the moved source pointer) */ |
1030
|
160124
|
|
|
|
|
count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); |
1031
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
/* This optimization is by Ben Tilly and it does |
1033
|
|
|
|
|
|
* things differently from what Sarathy (gsar) |
1034
|
|
|
|
|
|
* is describing. The downside of this optimization is |
1035
|
|
|
|
|
|
* that leaves "holes" (uninitialized and hopefully unused areas) |
1036
|
|
|
|
|
|
* to the Perl stack, but on the other hand this |
1037
|
|
|
|
|
|
* shouldn't be a problem. If Sarathy's idea gets |
1038
|
|
|
|
|
|
* implemented, this optimization should become |
1039
|
|
|
|
|
|
* irrelevant. --jhi */ |
1040
|
160124
|
50
|
|
|
|
if (shift < count) |
1041
|
|
|
|
|
|
shift = count; /* Avoid shifting too often --Ben Tilly */ |
1042
|
|
|
|
|
|
|
1043
|
79340
|
|
|
|
|
EXTEND(SP,shift); |
1044
|
|
|
|
|
|
src = SP; |
1045
|
160124
|
|
|
|
|
dst = (SP += shift); |
1046
|
160124
|
|
|
|
|
PL_markstack_ptr[-1] += shift; |
1047
|
160124
|
|
|
|
|
*PL_markstack_ptr += shift; |
1048
|
2343907
|
100
|
|
|
|
while (count--) |
1049
|
2105275
|
|
|
|
|
*dst-- = *src--; |
1050
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
/* copy the new items down to the destination list */ |
1052
|
8633708
|
|
|
|
|
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; |
1053
|
8633708
|
100
|
|
|
|
if (gimme == G_ARRAY) { |
1054
|
|
|
|
|
|
/* add returned items to the collection (making mortal copies |
1055
|
|
|
|
|
|
* if necessary), then clear the current temps stack frame |
1056
|
|
|
|
|
|
* *except* for those items. We do this splicing the items |
1057
|
|
|
|
|
|
* into the start of the tmps frame (so some items may be on |
1058
|
|
|
|
|
|
* the tmps stack twice), then moving PL_tmps_floor above |
1059
|
|
|
|
|
|
* them, then freeing the frame. That way, the only tmps that |
1060
|
|
|
|
|
|
* accumulate over iterations are the return values for map. |
1061
|
|
|
|
|
|
* We have to do to this way so that everything gets correctly |
1062
|
|
|
|
|
|
* freed if we die during the map. |
1063
|
|
|
|
|
|
*/ |
1064
|
|
|
|
|
|
I32 tmpsbase; |
1065
|
|
|
|
|
|
I32 i = items; |
1066
|
|
|
|
|
|
/* make space for the slice */ |
1067
|
8633558
|
100
|
|
|
|
EXTEND_MORTAL(items); |
1068
|
8633558
|
|
|
|
|
tmpsbase = PL_tmps_floor + 1; |
1069
|
8633558
|
50
|
|
|
|
Move(PL_tmps_stack + tmpsbase, |
1070
|
|
|
|
|
|
PL_tmps_stack + tmpsbase + items, |
1071
|
|
|
|
|
|
PL_tmps_ix - PL_tmps_floor, |
1072
|
|
|
|
|
|
SV*); |
1073
|
8633558
|
|
|
|
|
PL_tmps_ix += items; |
1074
|
|
|
|
|
|
|
1075
|
23512600
|
100
|
|
|
|
while (i-- > 0) { |
1076
|
10572579
|
|
|
|
|
SV *sv = POPs; |
1077
|
10572579
|
100
|
|
|
|
if (!SvTEMP(sv)) |
1078
|
5990599
|
|
|
|
|
sv = sv_mortalcopy(sv); |
1079
|
10572579
|
|
|
|
|
*dst-- = sv; |
1080
|
15829680
|
|
|
|
|
PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv); |
1081
|
|
|
|
|
|
} |
1082
|
|
|
|
|
|
/* clear the stack frame except for the items */ |
1083
|
8633558
|
|
|
|
|
PL_tmps_floor += items; |
1084
|
8633558
|
50
|
|
|
|
FREETMPS; |
1085
|
|
|
|
|
|
/* FREETMPS may have cleared the TEMP flag on some of the items */ |
1086
|
|
|
|
|
|
i = items; |
1087
|
23512600
|
100
|
|
|
|
while (i-- > 0) |
1088
|
10572579
|
|
|
|
|
SvTEMP_on(PL_tmps_stack[--tmpsbase]); |
1089
|
|
|
|
|
|
} |
1090
|
|
|
|
|
|
else { |
1091
|
|
|
|
|
|
/* scalar context: we don't care about which values map returns |
1092
|
|
|
|
|
|
* (we use undef here). And so we certainly don't want to do mortal |
1093
|
|
|
|
|
|
* copies of meaningless values. */ |
1094
|
328
|
100
|
|
|
|
while (items-- > 0) { |
1095
|
178
|
|
|
|
|
(void)POPs; |
1096
|
178
|
|
|
|
|
*dst-- = &PL_sv_undef; |
1097
|
|
|
|
|
|
} |
1098
|
150
|
100
|
|
|
|
FREETMPS; |
1099
|
|
|
|
|
|
} |
1100
|
|
|
|
|
|
} |
1101
|
|
|
|
|
|
else { |
1102
|
423962
|
100
|
|
|
|
FREETMPS; |
1103
|
|
|
|
|
|
} |
1104
|
9057670
|
|
|
|
|
LEAVE_with_name("grep_item"); /* exit inner scope */ |
1105
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
/* All done yet? */ |
1107
|
9057670
|
100
|
|
|
|
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { |
1108
|
|
|
|
|
|
|
1109
|
2931055
|
|
|
|
|
(void)POPMARK; /* pop top */ |
1110
|
2931055
|
|
|
|
|
LEAVE_with_name("grep"); /* exit outer scope */ |
1111
|
2931055
|
|
|
|
|
(void)POPMARK; /* pop src */ |
1112
|
2931055
|
|
|
|
|
items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; |
1113
|
2931055
|
|
|
|
|
(void)POPMARK; /* pop dst */ |
1114
|
2931055
|
|
|
|
|
SP = PL_stack_base + POPMARK; /* pop original mark */ |
1115
|
2931055
|
100
|
|
|
|
if (gimme == G_SCALAR) { |
1116
|
44
|
100
|
|
|
|
if (PL_op->op_private & OPpGREP_LEX) { |
1117
|
2
|
|
|
|
|
SV* sv = sv_newmortal(); |
1118
|
2
|
|
|
|
|
sv_setiv(sv, items); |
1119
|
2
|
|
|
|
|
PUSHs(sv); |
1120
|
|
|
|
|
|
} |
1121
|
|
|
|
|
|
else { |
1122
|
42
|
|
|
|
|
dTARGET; |
1123
|
42
|
50
|
|
|
|
XPUSHi(items); |
|
|
50
|
|
|
|
|
1124
|
|
|
|
|
|
} |
1125
|
|
|
|
|
|
} |
1126
|
2931011
|
100
|
|
|
|
else if (gimme == G_ARRAY) |
1127
|
2910293
|
|
|
|
|
SP += items; |
1128
|
2931055
|
|
|
|
|
RETURN; |
1129
|
|
|
|
|
|
} |
1130
|
|
|
|
|
|
else { |
1131
|
|
|
|
|
|
SV *src; |
1132
|
|
|
|
|
|
|
1133
|
6126615
|
|
|
|
|
ENTER_with_name("grep_item"); /* enter inner scope */ |
1134
|
6126615
|
|
|
|
|
SAVEVPTR(PL_curpm); |
1135
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
/* set $_ to the new source item */ |
1137
|
6126615
|
|
|
|
|
src = PL_stack_base[PL_markstack_ptr[-1]]; |
1138
|
6126615
|
100
|
|
|
|
if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src); |
1139
|
6126615
|
|
|
|
|
SvTEMP_off(src); |
1140
|
6126615
|
100
|
|
|
|
if (PL_op->op_private & OPpGREP_LEX) |
1141
|
10
|
|
|
|
|
PAD_SVl(PL_op->op_targ) = src; |
1142
|
|
|
|
|
|
else |
1143
|
12253210
|
|
|
|
|
DEFSV_set(src); |
1144
|
|
|
|
|
|
|
1145
|
7593701
|
|
|
|
|
RETURNOP(cLOGOP->op_other); |
1146
|
|
|
|
|
|
} |
1147
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
/* Range stuff. */ |
1150
|
|
|
|
|
|
|
1151
|
190998
|
|
|
|
|
PP(pp_range) |
1152
|
|
|
|
|
|
{ |
1153
|
|
|
|
|
|
dVAR; |
1154
|
190998
|
100
|
|
|
|
if (GIMME == G_ARRAY) |
|
|
100
|
|
|
|
|
1155
|
176090
|
|
|
|
|
return NORMAL; |
1156
|
14908
|
50
|
|
|
|
if (SvTRUEx(PAD_SV(PL_op->op_targ))) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
1157
|
7554
|
|
|
|
|
return cLOGOP->op_other; |
1158
|
|
|
|
|
|
else |
1159
|
99896
|
|
|
|
|
return NORMAL; |
1160
|
|
|
|
|
|
} |
1161
|
|
|
|
|
|
|
1162
|
183444
|
|
|
|
|
PP(pp_flip) |
1163
|
|
|
|
|
|
{ |
1164
|
|
|
|
|
|
dVAR; |
1165
|
183444
|
|
|
|
|
dSP; |
1166
|
|
|
|
|
|
|
1167
|
183444
|
100
|
|
|
|
if (GIMME == G_ARRAY) { |
|
|
100
|
|
|
|
|
1168
|
176090
|
|
|
|
|
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); |
1169
|
|
|
|
|
|
} |
1170
|
|
|
|
|
|
else { |
1171
|
7354
|
|
|
|
|
dTOPss; |
1172
|
7354
|
|
|
|
|
SV * const targ = PAD_SV(PL_op->op_targ); |
1173
|
|
|
|
|
|
int flip = 0; |
1174
|
|
|
|
|
|
|
1175
|
7354
|
100
|
|
|
|
if (PL_op->op_private & OPpFLIP_LINENUM) { |
1176
|
748
|
100
|
|
|
|
if (GvIO(PL_last_in_gv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1177
|
724
|
50
|
|
|
|
flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); |
1178
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
else { |
1180
|
24
|
|
|
|
|
GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); |
1181
|
24
|
50
|
|
|
|
if (gv && GvSV(gv)) |
|
|
50
|
|
|
|
|
1182
|
24
|
100
|
|
|
|
flip = SvIV(sv) == SvIV(GvSV(gv)); |
|
|
50
|
|
|
|
|
1183
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
} else { |
1185
|
6606
|
50
|
|
|
|
flip = SvTRUE(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1186
|
|
|
|
|
|
} |
1187
|
7354
|
100
|
|
|
|
if (flip) { |
1188
|
852
|
|
|
|
|
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); |
1189
|
852
|
100
|
|
|
|
if (PL_op->op_flags & OPf_SPECIAL) { |
1190
|
544
|
|
|
|
|
sv_setiv(targ, 1); |
1191
|
544
|
|
|
|
|
SETs(targ); |
1192
|
544
|
|
|
|
|
RETURN; |
1193
|
|
|
|
|
|
} |
1194
|
|
|
|
|
|
else { |
1195
|
308
|
|
|
|
|
sv_setiv(targ, 0); |
1196
|
308
|
|
|
|
|
SP--; |
1197
|
308
|
|
|
|
|
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); |
1198
|
|
|
|
|
|
} |
1199
|
|
|
|
|
|
} |
1200
|
6502
|
|
|
|
|
sv_setpvs(TARG, ""); |
1201
|
6502
|
|
|
|
|
SETs(targ); |
1202
|
95693
|
|
|
|
|
RETURN; |
1203
|
|
|
|
|
|
} |
1204
|
|
|
|
|
|
} |
1205
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
/* This code tries to decide if "$left .. $right" should use the |
1207
|
|
|
|
|
|
magical string increment, or if the range is numeric (we make |
1208
|
|
|
|
|
|
an exception for .."0" [#18165]). AMS 20021031. */ |
1209
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
#define RANGE_IS_NUMERIC(left,right) ( \ |
1211
|
|
|
|
|
|
SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ |
1212
|
|
|
|
|
|
SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ |
1213
|
|
|
|
|
|
(((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ |
1214
|
|
|
|
|
|
looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ |
1215
|
|
|
|
|
|
&& (!SvOK(right) || looks_like_number(right)))) |
1216
|
|
|
|
|
|
|
1217
|
183952
|
|
|
|
|
PP(pp_flop) |
1218
|
|
|
|
|
|
{ |
1219
|
183952
|
|
|
|
|
dVAR; dSP; |
1220
|
|
|
|
|
|
|
1221
|
358609
|
100
|
|
|
|
if (GIMME == G_ARRAY) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1222
|
176090
|
|
|
|
|
dPOPPOPssrl; |
1223
|
|
|
|
|
|
|
1224
|
87339
|
|
|
|
|
SvGETMAGIC(left); |
1225
|
87331
|
|
|
|
|
SvGETMAGIC(right); |
1226
|
|
|
|
|
|
|
1227
|
176090
|
100
|
|
|
|
if (RANGE_IS_NUMERIC(left,right)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1228
|
|
|
|
|
|
IV i, j; |
1229
|
|
|
|
|
|
IV max; |
1230
|
349843
|
100
|
|
|
|
if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) || |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1231
|
349817
|
50
|
|
|
|
(SvOK(right) && (SvIOK(right) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
1232
|
87080
|
0
|
|
|
|
? SvIsUV(right) && SvUV(right) > IV_MAX |
|
|
0
|
|
|
|
|
1233
|
34
|
|
|
|
|
: SvNV_nomg(right) > IV_MAX))) |
1234
|
0
|
|
|
|
|
DIE(aTHX_ "Range iterator outside integer range"); |
1235
|
175638
|
100
|
|
|
|
i = SvIV_nomg(left); |
1236
|
175638
|
100
|
|
|
|
max = SvIV_nomg(right); |
1237
|
349248
|
100
|
|
|
|
if (max >= i) { |
|
|
100
|
|
|
|
|
1238
|
173610
|
|
|
|
|
j = max - i + 1; |
1239
|
|
|
|
|
|
if (j > SSize_t_MAX) |
1240
|
|
|
|
|
|
Perl_croak(aTHX_ "Out of memory during list extend"); |
1241
|
173610
|
100
|
|
|
|
EXTEND_MORTAL(j); |
1242
|
174730
|
|
|
|
|
EXTEND(SP, j); |
1243
|
|
|
|
|
|
} |
1244
|
|
|
|
|
|
else |
1245
|
|
|
|
|
|
j = 0; |
1246
|
1382316
|
100
|
|
|
|
while (j--) { |
1247
|
1206678
|
|
|
|
|
SV * const sv = sv_2mortal(newSViv(i++)); |
1248
|
1206678
|
|
|
|
|
PUSHs(sv); |
1249
|
|
|
|
|
|
} |
1250
|
|
|
|
|
|
} |
1251
|
|
|
|
|
|
else { |
1252
|
|
|
|
|
|
STRLEN len, llen; |
1253
|
452
|
100
|
|
|
|
const char * const lpv = SvPV_nomg_const(left, llen); |
1254
|
452
|
100
|
|
|
|
const char * const tmps = SvPV_nomg_const(right, len); |
1255
|
|
|
|
|
|
|
1256
|
452
|
|
|
|
|
SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); |
1257
|
48460
|
100
|
|
|
|
while (!SvNIOKp(sv) && SvCUR(sv) <= len) { |
|
|
100
|
|
|
|
|
1258
|
48214
|
100
|
|
|
|
XPUSHs(sv); |
1259
|
48214
|
100
|
|
|
|
if (strEQ(SvPVX_const(sv),tmps)) |
1260
|
|
|
|
|
|
break; |
1261
|
47782
|
|
|
|
|
sv = sv_2mortal(newSVsv(sv)); |
1262
|
47782
|
|
|
|
|
sv_inc(sv); |
1263
|
|
|
|
|
|
} |
1264
|
|
|
|
|
|
} |
1265
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
else { |
1267
|
7862
|
|
|
|
|
dTOPss; |
1268
|
7862
|
|
|
|
|
SV * const targ = PAD_SV(cUNOP->op_first->op_targ); |
1269
|
|
|
|
|
|
int flop = 0; |
1270
|
7862
|
|
|
|
|
sv_inc(targ); |
1271
|
|
|
|
|
|
|
1272
|
7862
|
100
|
|
|
|
if (PL_op->op_private & OPpFLIP_LINENUM) { |
1273
|
96
|
100
|
|
|
|
if (GvIO(PL_last_in_gv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1274
|
86
|
50
|
|
|
|
flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); |
1275
|
|
|
|
|
|
} |
1276
|
|
|
|
|
|
else { |
1277
|
10
|
|
|
|
|
GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); |
1278
|
10
|
50
|
|
|
|
if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1279
|
|
|
|
|
|
} |
1280
|
|
|
|
|
|
} |
1281
|
|
|
|
|
|
else { |
1282
|
7766
|
50
|
|
|
|
flop = SvTRUE(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
1283
|
|
|
|
|
|
} |
1284
|
|
|
|
|
|
|
1285
|
7862
|
100
|
|
|
|
if (flop) { |
1286
|
584
|
|
|
|
|
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); |
1287
|
584
|
|
|
|
|
sv_catpvs(targ, "E0"); |
1288
|
|
|
|
|
|
} |
1289
|
7862
|
|
|
|
|
SETs(targ); |
1290
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
1292
|
183952
|
|
|
|
|
RETURN; |
1293
|
|
|
|
|
|
} |
1294
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
/* Control. */ |
1296
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
static const char * const context_name[] = { |
1298
|
|
|
|
|
|
"pseudo-block", |
1299
|
|
|
|
|
|
NULL, /* CXt_WHEN never actually needs "block" */ |
1300
|
|
|
|
|
|
NULL, /* CXt_BLOCK never actually needs "block" */ |
1301
|
|
|
|
|
|
NULL, /* CXt_GIVEN never actually needs "block" */ |
1302
|
|
|
|
|
|
NULL, /* CXt_LOOP_FOR never actually needs "loop" */ |
1303
|
|
|
|
|
|
NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ |
1304
|
|
|
|
|
|
NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ |
1305
|
|
|
|
|
|
NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ |
1306
|
|
|
|
|
|
"subroutine", |
1307
|
|
|
|
|
|
"format", |
1308
|
|
|
|
|
|
"eval", |
1309
|
|
|
|
|
|
"substitution", |
1310
|
|
|
|
|
|
}; |
1311
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
STATIC I32 |
1313
|
328878
|
|
|
|
|
S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) |
1314
|
|
|
|
|
|
{ |
1315
|
|
|
|
|
|
dVAR; |
1316
|
|
|
|
|
|
I32 i; |
1317
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
PERL_ARGS_ASSERT_DOPOPTOLABEL; |
1319
|
|
|
|
|
|
|
1320
|
826492
|
100
|
|
|
|
for (i = cxstack_ix; i >= 0; i--) { |
1321
|
662050
|
|
|
|
|
const PERL_CONTEXT * const cx = &cxstack[i]; |
1322
|
662050
|
|
|
|
|
switch (CxTYPE(cx)) { |
1323
|
|
|
|
|
|
case CXt_SUBST: |
1324
|
|
|
|
|
|
case CXt_SUB: |
1325
|
|
|
|
|
|
case CXt_FORMAT: |
1326
|
|
|
|
|
|
case CXt_EVAL: |
1327
|
|
|
|
|
|
case CXt_NULL: |
1328
|
|
|
|
|
|
/* diag_listed_as: Exiting subroutine via %s */ |
1329
|
5052
|
50
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", |
1330
|
2526
|
0
|
|
|
|
context_name[CxTYPE(cx)], OP_NAME(PL_op)); |
1331
|
2526
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_NULL) |
1332
|
|
|
|
|
|
return -1; |
1333
|
|
|
|
|
|
break; |
1334
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
1335
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
1336
|
|
|
|
|
|
case CXt_LOOP_FOR: |
1337
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
1338
|
|
|
|
|
|
{ |
1339
|
398290
|
|
|
|
|
STRLEN cx_label_len = 0; |
1340
|
398290
|
|
|
|
|
U32 cx_label_flags = 0; |
1341
|
398290
|
|
|
|
|
const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); |
1342
|
1056955
|
100
|
|
|
|
if (!cx_label || !( |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1343
|
329478
|
|
|
|
|
( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? |
1344
|
4
|
|
|
|
|
(flags & SVf_UTF8) |
1345
|
0
|
|
|
|
|
? (bytes_cmp_utf8( |
1346
|
|
|
|
|
|
(const U8*)cx_label, cx_label_len, |
1347
|
|
|
|
|
|
(const U8*)label, len) == 0) |
1348
|
4
|
|
|
|
|
: (bytes_cmp_utf8( |
1349
|
|
|
|
|
|
(const U8*)label, len, |
1350
|
|
|
|
|
|
(const U8*)cx_label, cx_label_len) == 0) |
1351
|
493629
|
50
|
|
|
|
: (len == cx_label_len && ((cx_label == label) |
1352
|
328892
|
100
|
|
|
|
|| memEQ(cx_label, label, len))) )) { |
1353
|
|
|
|
|
|
DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", |
1354
|
|
|
|
|
|
(long)i, cx_label)); |
1355
|
69422
|
|
|
|
|
continue; |
1356
|
|
|
|
|
|
} |
1357
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label)); |
1358
|
|
|
|
|
|
return i; |
1359
|
|
|
|
|
|
} |
1360
|
|
|
|
|
|
} |
1361
|
|
|
|
|
|
} |
1362
|
|
|
|
|
|
return i; |
1363
|
|
|
|
|
|
} |
1364
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
1366
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
I32 |
1368
|
7890657
|
|
|
|
|
Perl_dowantarray(pTHX) |
1369
|
|
|
|
|
|
{ |
1370
|
|
|
|
|
|
dVAR; |
1371
|
7890657
|
|
|
|
|
const I32 gimme = block_gimme(); |
1372
|
7890657
|
100
|
|
|
|
return (gimme == G_VOID) ? G_SCALAR : gimme; |
1373
|
|
|
|
|
|
} |
1374
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
I32 |
1376
|
96180580
|
|
|
|
|
Perl_block_gimme(pTHX) |
1377
|
|
|
|
|
|
{ |
1378
|
|
|
|
|
|
dVAR; |
1379
|
96180580
|
|
|
|
|
const I32 cxix = dopoptosub(cxstack_ix); |
1380
|
96180580
|
100
|
|
|
|
if (cxix < 0) |
1381
|
|
|
|
|
|
return G_VOID; |
1382
|
|
|
|
|
|
|
1383
|
96155296
|
|
|
|
|
switch (cxstack[cxix].blk_gimme) { |
1384
|
|
|
|
|
|
case G_VOID: |
1385
|
|
|
|
|
|
return G_VOID; |
1386
|
|
|
|
|
|
case G_SCALAR: |
1387
|
47280558
|
|
|
|
|
return G_SCALAR; |
1388
|
|
|
|
|
|
case G_ARRAY: |
1389
|
16182566
|
|
|
|
|
return G_ARRAY; |
1390
|
|
|
|
|
|
default: |
1391
|
48163177
|
|
|
|
|
Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); |
1392
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1393
|
|
|
|
|
|
return 0; |
1394
|
|
|
|
|
|
} |
1395
|
|
|
|
|
|
} |
1396
|
|
|
|
|
|
|
1397
|
|
|
|
|
|
I32 |
1398
|
730
|
|
|
|
|
Perl_is_lvalue_sub(pTHX) |
1399
|
|
|
|
|
|
{ |
1400
|
|
|
|
|
|
dVAR; |
1401
|
730
|
|
|
|
|
const I32 cxix = dopoptosub(cxstack_ix); |
1402
|
|
|
|
|
|
assert(cxix >= 0); /* We should only be called from inside subs */ |
1403
|
|
|
|
|
|
|
1404
|
730
|
100
|
|
|
|
if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) |
|
|
50
|
|
|
|
|
1405
|
614
|
|
|
|
|
return CxLVAL(cxstack + cxix); |
1406
|
|
|
|
|
|
else |
1407
|
|
|
|
|
|
return 0; |
1408
|
|
|
|
|
|
} |
1409
|
|
|
|
|
|
|
1410
|
|
|
|
|
|
/* only used by PUSHSUB */ |
1411
|
|
|
|
|
|
I32 |
1412
|
32
|
|
|
|
|
Perl_was_lvalue_sub(pTHX) |
1413
|
|
|
|
|
|
{ |
1414
|
|
|
|
|
|
dVAR; |
1415
|
32
|
|
|
|
|
const I32 cxix = dopoptosub(cxstack_ix-1); |
1416
|
|
|
|
|
|
assert(cxix >= 0); /* We should only be called from inside subs */ |
1417
|
|
|
|
|
|
|
1418
|
32
|
100
|
|
|
|
if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) |
|
|
50
|
|
|
|
|
1419
|
27
|
|
|
|
|
return CxLVAL(cxstack + cxix); |
1420
|
|
|
|
|
|
else |
1421
|
|
|
|
|
|
return 0; |
1422
|
|
|
|
|
|
} |
1423
|
|
|
|
|
|
|
1424
|
|
|
|
|
|
STATIC I32 |
1425
|
387704903
|
|
|
|
|
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) |
1426
|
|
|
|
|
|
{ |
1427
|
|
|
|
|
|
dVAR; |
1428
|
|
|
|
|
|
I32 i; |
1429
|
|
|
|
|
|
|
1430
|
|
|
|
|
|
PERL_ARGS_ASSERT_DOPOPTOSUB_AT; |
1431
|
|
|
|
|
|
|
1432
|
646433084
|
100
|
|
|
|
for (i = startingblock; i >= 0; i--) { |
1433
|
451501661
|
|
|
|
|
const PERL_CONTEXT * const cx = &cxstk[i]; |
1434
|
451501661
|
|
|
|
|
switch (CxTYPE(cx)) { |
1435
|
|
|
|
|
|
default: |
1436
|
65665706
|
|
|
|
|
continue; |
1437
|
|
|
|
|
|
case CXt_SUB: |
1438
|
|
|
|
|
|
/* in sub foo { /(?{...})/ }, foo ends up on the CX stack |
1439
|
|
|
|
|
|
* twice; the first for the normal foo() call, and the second |
1440
|
|
|
|
|
|
* for a faked up re-entry into the sub to execute the |
1441
|
|
|
|
|
|
* code block. Hide this faked entry from the world. */ |
1442
|
385071715
|
100
|
|
|
|
if (cx->cx_type & CXp_SUB_RE_FAKE) |
1443
|
106
|
|
|
|
|
continue; |
1444
|
|
|
|
|
|
case CXt_EVAL: |
1445
|
|
|
|
|
|
case CXt_FORMAT: |
1446
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); |
1447
|
|
|
|
|
|
return i; |
1448
|
|
|
|
|
|
} |
1449
|
|
|
|
|
|
} |
1450
|
|
|
|
|
|
return i; |
1451
|
|
|
|
|
|
} |
1452
|
|
|
|
|
|
|
1453
|
|
|
|
|
|
STATIC I32 |
1454
|
|
|
|
|
|
S_dopoptoeval(pTHX_ I32 startingblock) |
1455
|
|
|
|
|
|
{ |
1456
|
|
|
|
|
|
dVAR; |
1457
|
|
|
|
|
|
I32 i; |
1458
|
403408
|
100
|
|
|
|
for (i = startingblock; i >= 0; i--) { |
1459
|
561537
|
|
|
|
|
const PERL_CONTEXT *cx = &cxstack[i]; |
1460
|
561537
|
100
|
|
|
|
switch (CxTYPE(cx)) { |
1461
|
|
|
|
|
|
default: |
1462
|
242090
|
|
|
|
|
continue; |
1463
|
|
|
|
|
|
case CXt_EVAL: |
1464
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i)); |
1465
|
|
|
|
|
|
return i; |
1466
|
|
|
|
|
|
} |
1467
|
|
|
|
|
|
} |
1468
|
|
|
|
|
|
return i; |
1469
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
STATIC I32 |
1472
|
11356549
|
|
|
|
|
S_dopoptoloop(pTHX_ I32 startingblock) |
1473
|
|
|
|
|
|
{ |
1474
|
|
|
|
|
|
dVAR; |
1475
|
|
|
|
|
|
I32 i; |
1476
|
25193089
|
100
|
|
|
|
for (i = startingblock; i >= 0; i--) { |
1477
|
19374847
|
|
|
|
|
const PERL_CONTEXT * const cx = &cxstack[i]; |
1478
|
19374847
|
|
|
|
|
switch (CxTYPE(cx)) { |
1479
|
|
|
|
|
|
case CXt_SUBST: |
1480
|
|
|
|
|
|
case CXt_SUB: |
1481
|
|
|
|
|
|
case CXt_FORMAT: |
1482
|
|
|
|
|
|
case CXt_EVAL: |
1483
|
|
|
|
|
|
case CXt_NULL: |
1484
|
|
|
|
|
|
/* diag_listed_as: Exiting subroutine via %s */ |
1485
|
124
|
50
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", |
1486
|
62
|
0
|
|
|
|
context_name[CxTYPE(cx)], OP_NAME(PL_op)); |
1487
|
62
|
100
|
|
|
|
if ((CxTYPE(cx)) == CXt_NULL) |
1488
|
|
|
|
|
|
return -1; |
1489
|
|
|
|
|
|
break; |
1490
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
1491
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
1492
|
|
|
|
|
|
case CXt_LOOP_FOR: |
1493
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
1494
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); |
1495
|
|
|
|
|
|
return i; |
1496
|
|
|
|
|
|
} |
1497
|
|
|
|
|
|
} |
1498
|
|
|
|
|
|
return i; |
1499
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
STATIC I32 |
1502
|
312
|
|
|
|
|
S_dopoptogiven(pTHX_ I32 startingblock) |
1503
|
|
|
|
|
|
{ |
1504
|
|
|
|
|
|
dVAR; |
1505
|
|
|
|
|
|
I32 i; |
1506
|
1074
|
100
|
|
|
|
for (i = startingblock; i >= 0; i--) { |
1507
|
914
|
|
|
|
|
const PERL_CONTEXT *cx = &cxstack[i]; |
1508
|
914
|
|
|
|
|
switch (CxTYPE(cx)) { |
1509
|
|
|
|
|
|
default: |
1510
|
610
|
|
|
|
|
continue; |
1511
|
|
|
|
|
|
case CXt_GIVEN: |
1512
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i)); |
1513
|
|
|
|
|
|
return i; |
1514
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
1515
|
|
|
|
|
|
assert(!CxFOREACHDEF(cx)); |
1516
|
|
|
|
|
|
break; |
1517
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
1518
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
1519
|
|
|
|
|
|
case CXt_LOOP_FOR: |
1520
|
30
|
50
|
|
|
|
if (CxFOREACHDEF(cx)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
1521
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i)); |
1522
|
|
|
|
|
|
return i; |
1523
|
|
|
|
|
|
} |
1524
|
|
|
|
|
|
} |
1525
|
|
|
|
|
|
} |
1526
|
|
|
|
|
|
return i; |
1527
|
|
|
|
|
|
} |
1528
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
STATIC I32 |
1530
|
|
|
|
|
|
S_dopoptowhen(pTHX_ I32 startingblock) |
1531
|
|
|
|
|
|
{ |
1532
|
|
|
|
|
|
dVAR; |
1533
|
|
|
|
|
|
I32 i; |
1534
|
113
|
100
|
|
|
|
for (i = startingblock; i >= 0; i--) { |
1535
|
144
|
|
|
|
|
const PERL_CONTEXT *cx = &cxstack[i]; |
1536
|
144
|
100
|
|
|
|
switch (CxTYPE(cx)) { |
1537
|
|
|
|
|
|
default: |
1538
|
78
|
|
|
|
|
continue; |
1539
|
|
|
|
|
|
case CXt_WHEN: |
1540
|
|
|
|
|
|
DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i)); |
1541
|
|
|
|
|
|
return i; |
1542
|
|
|
|
|
|
} |
1543
|
|
|
|
|
|
} |
1544
|
|
|
|
|
|
return i; |
1545
|
|
|
|
|
|
} |
1546
|
|
|
|
|
|
|
1547
|
|
|
|
|
|
void |
1548
|
26747967
|
|
|
|
|
Perl_dounwind(pTHX_ I32 cxix) |
1549
|
|
|
|
|
|
{ |
1550
|
|
|
|
|
|
dVAR; |
1551
|
|
|
|
|
|
I32 optype; |
1552
|
|
|
|
|
|
|
1553
|
26747967
|
50
|
|
|
|
if (!PL_curstackinfo) /* can happen if die during thread cloning */ |
1554
|
26747967
|
|
|
|
|
return; |
1555
|
|
|
|
|
|
|
1556
|
61339221
|
100
|
|
|
|
while (cxstack_ix > cxix) { |
1557
|
|
|
|
|
|
SV *sv; |
1558
|
34591254
|
|
|
|
|
PERL_CONTEXT *cx = &cxstack[cxstack_ix]; |
1559
|
|
|
|
|
|
DEBUG_CX("UNWIND"); \ |
1560
|
|
|
|
|
|
/* Note: we don't need to restore the base context info till the end. */ |
1561
|
34591254
|
|
|
|
|
switch (CxTYPE(cx)) { |
1562
|
|
|
|
|
|
case CXt_SUBST: |
1563
|
16
|
|
|
|
|
POPSUBST(cx); |
1564
|
16
|
|
|
|
|
continue; /* not break */ |
1565
|
|
|
|
|
|
case CXt_SUB: |
1566
|
302085
|
100
|
|
|
|
POPSUB(cx,sv); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1567
|
201630
|
|
|
|
|
LEAVESUB(sv); |
1568
|
201630
|
|
|
|
|
break; |
1569
|
|
|
|
|
|
case CXt_EVAL: |
1570
|
334
|
100
|
|
|
|
POPEVAL(cx); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1571
|
|
|
|
|
|
break; |
1572
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
1573
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
1574
|
|
|
|
|
|
case CXt_LOOP_FOR: |
1575
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
1576
|
3909043
|
50
|
|
|
|
POPLOOP(cx); |
|
|
100
|
|
|
|
|
1577
|
|
|
|
|
|
break; |
1578
|
|
|
|
|
|
case CXt_NULL: |
1579
|
|
|
|
|
|
break; |
1580
|
|
|
|
|
|
case CXt_FORMAT: |
1581
|
69
|
50
|
|
|
|
POPFORMAT(cx); |
|
|
50
|
|
|
|
|
1582
|
46
|
|
|
|
|
break; |
1583
|
|
|
|
|
|
} |
1584
|
34591246
|
|
|
|
|
cxstack_ix--; |
1585
|
|
|
|
|
|
} |
1586
|
|
|
|
|
|
PERL_UNUSED_VAR(optype); |
1587
|
|
|
|
|
|
} |
1588
|
|
|
|
|
|
|
1589
|
|
|
|
|
|
void |
1590
|
2384
|
|
|
|
|
Perl_qerror(pTHX_ SV *err) |
1591
|
|
|
|
|
|
{ |
1592
|
|
|
|
|
|
dVAR; |
1593
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
PERL_ARGS_ASSERT_QERROR; |
1595
|
|
|
|
|
|
|
1596
|
2384
|
100
|
|
|
|
if (PL_in_eval) { |
1597
|
2120
|
100
|
|
|
|
if (PL_in_eval & EVAL_KEEPERR) { |
1598
|
2
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, |
1599
|
|
|
|
|
|
SVfARG(err)); |
1600
|
|
|
|
|
|
} |
1601
|
|
|
|
|
|
else |
1602
|
2118
|
50
|
|
|
|
sv_catsv(ERRSV, err); |
1603
|
|
|
|
|
|
} |
1604
|
264
|
50
|
|
|
|
else if (PL_errors) |
1605
|
264
|
|
|
|
|
sv_catsv(PL_errors, err); |
1606
|
|
|
|
|
|
else |
1607
|
0
|
|
|
|
|
Perl_warn(aTHX_ "%"SVf, SVfARG(err)); |
1608
|
2384
|
50
|
|
|
|
if (PL_parser) |
1609
|
2384
|
|
|
|
|
++PL_parser->error_count; |
1610
|
2384
|
|
|
|
|
} |
1611
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
void |
1613
|
320537
|
|
|
|
|
Perl_die_unwind(pTHX_ SV *msv) |
1614
|
|
|
|
|
|
{ |
1615
|
|
|
|
|
|
dVAR; |
1616
|
320537
|
|
|
|
|
SV *exceptsv = sv_mortalcopy(msv); |
1617
|
320537
|
|
|
|
|
U8 in_eval = PL_in_eval; |
1618
|
|
|
|
|
|
PERL_ARGS_ASSERT_DIE_UNWIND; |
1619
|
|
|
|
|
|
|
1620
|
320537
|
100
|
|
|
|
if (in_eval) { |
1621
|
|
|
|
|
|
I32 cxix; |
1622
|
|
|
|
|
|
I32 gimme; |
1623
|
|
|
|
|
|
|
1624
|
|
|
|
|
|
/* |
1625
|
|
|
|
|
|
* Historically, perl used to set ERRSV ($@) early in the die |
1626
|
|
|
|
|
|
* process and rely on it not getting clobbered during unwinding. |
1627
|
|
|
|
|
|
* That sucked, because it was liable to get clobbered, so the |
1628
|
|
|
|
|
|
* setting of ERRSV used to emit the exception from eval{} has |
1629
|
|
|
|
|
|
* been moved to much later, after unwinding (see just before |
1630
|
|
|
|
|
|
* JMPENV_JUMP below). However, some modules were relying on the |
1631
|
|
|
|
|
|
* early setting, by examining $@ during unwinding to use it as |
1632
|
|
|
|
|
|
* a flag indicating whether the current unwinding was caused by |
1633
|
|
|
|
|
|
* an exception. It was never a reliable flag for that purpose, |
1634
|
|
|
|
|
|
* being totally open to false positives even without actual |
1635
|
|
|
|
|
|
* clobberage, but was useful enough for production code to |
1636
|
|
|
|
|
|
* semantically rely on it. |
1637
|
|
|
|
|
|
* |
1638
|
|
|
|
|
|
* We'd like to have a proper introspective interface that |
1639
|
|
|
|
|
|
* explicitly describes the reason for whatever unwinding |
1640
|
|
|
|
|
|
* operations are currently in progress, so that those modules |
1641
|
|
|
|
|
|
* work reliably and $@ isn't further overloaded. But we don't |
1642
|
|
|
|
|
|
* have one yet. In its absence, as a stopgap measure, ERRSV is |
1643
|
|
|
|
|
|
* now *additionally* set here, before unwinding, to serve as the |
1644
|
|
|
|
|
|
* (unreliable) flag that it used to. |
1645
|
|
|
|
|
|
* |
1646
|
|
|
|
|
|
* This behaviour is temporary, and should be removed when a |
1647
|
|
|
|
|
|
* proper way to detect exceptional unwinding has been developed. |
1648
|
|
|
|
|
|
* As of 2010-12, the authors of modules relying on the hack |
1649
|
|
|
|
|
|
* are aware of the issue, because the modules failed on |
1650
|
|
|
|
|
|
* perls 5.13.{1..7} which had late setting of $@ without this |
1651
|
|
|
|
|
|
* early-setting hack. |
1652
|
|
|
|
|
|
*/ |
1653
|
319447
|
100
|
|
|
|
if (!(in_eval & EVAL_KEEPERR)) { |
1654
|
319253
|
|
|
|
|
SvTEMP_off(exceptsv); |
1655
|
319253
|
50
|
|
|
|
sv_setsv(ERRSV, exceptsv); |
1656
|
|
|
|
|
|
} |
1657
|
|
|
|
|
|
|
1658
|
319447
|
100
|
|
|
|
if (in_eval & EVAL_KEEPERR) { |
1659
|
160900
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, |
1660
|
|
|
|
|
|
SVfARG(exceptsv)); |
1661
|
|
|
|
|
|
} |
1662
|
|
|
|
|
|
|
1663
|
640954
|
100
|
|
|
|
while ((cxix = dopoptoeval(cxstack_ix)) < 0 |
1664
|
1030
|
50
|
|
|
|
&& PL_curstackinfo->si_prev) |
1665
|
|
|
|
|
|
{ |
1666
|
1030
|
|
|
|
|
dounwind(-1); |
1667
|
1030
|
50
|
|
|
|
POPSTACK; |
1668
|
|
|
|
|
|
} |
1669
|
|
|
|
|
|
|
1670
|
319447
|
50
|
|
|
|
if (cxix >= 0) { |
1671
|
|
|
|
|
|
I32 optype; |
1672
|
|
|
|
|
|
SV *namesv; |
1673
|
|
|
|
|
|
PERL_CONTEXT *cx; |
1674
|
|
|
|
|
|
SV **newsp; |
1675
|
|
|
|
|
|
COP *oldcop; |
1676
|
|
|
|
|
|
JMPENV *restartjmpenv; |
1677
|
|
|
|
|
|
OP *restartop; |
1678
|
|
|
|
|
|
|
1679
|
319447
|
100
|
|
|
|
if (cxix < cxstack_ix) |
1680
|
140662
|
|
|
|
|
dounwind(cxix); |
1681
|
|
|
|
|
|
|
1682
|
319447
|
|
|
|
|
POPBLOCK(cx,PL_curpm); |
1683
|
319447
|
50
|
|
|
|
if (CxTYPE(cx) != CXt_EVAL) { |
1684
|
|
|
|
|
|
STRLEN msglen; |
1685
|
0
|
0
|
|
|
|
const char* message = SvPVx_const(exceptsv, msglen); |
1686
|
0
|
0
|
|
|
|
PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1687
|
0
|
0
|
|
|
|
PerlIO_write(Perl_error_log, message, msglen); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
1688
|
0
|
|
|
|
|
my_exit(1); |
1689
|
|
|
|
|
|
} |
1690
|
319447
|
100
|
|
|
|
POPEVAL(cx); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1691
|
319447
|
|
|
|
|
namesv = cx->blk_eval.old_namesv; |
1692
|
319447
|
|
|
|
|
oldcop = cx->blk_oldcop; |
1693
|
319447
|
|
|
|
|
restartjmpenv = cx->blk_eval.cur_top_env; |
1694
|
319447
|
|
|
|
|
restartop = cx->blk_eval.retop; |
1695
|
|
|
|
|
|
|
1696
|
319447
|
100
|
|
|
|
if (gimme == G_SCALAR) |
1697
|
201927
|
|
|
|
|
*++newsp = &PL_sv_undef; |
1698
|
319447
|
|
|
|
|
PL_stack_sp = newsp; |
1699
|
|
|
|
|
|
|
1700
|
319447
|
|
|
|
|
LEAVE; |
1701
|
|
|
|
|
|
|
1702
|
|
|
|
|
|
/* LEAVE could clobber PL_curcop (see save_re_context()) |
1703
|
|
|
|
|
|
* XXX it might be better to find a way to avoid messing with |
1704
|
|
|
|
|
|
* PL_curcop in save_re_context() instead, but this is a more |
1705
|
|
|
|
|
|
* minimal fix --GSAR */ |
1706
|
319445
|
|
|
|
|
PL_curcop = oldcop; |
1707
|
|
|
|
|
|
|
1708
|
319445
|
100
|
|
|
|
if (optype == OP_REQUIRE) { |
1709
|
1796
|
50
|
|
|
|
(void)hv_store(GvHVn(PL_incgv), |
|
|
50
|
|
|
|
|
1710
|
|
|
|
|
|
SvPVX_const(namesv), |
1711
|
|
|
|
|
|
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), |
1712
|
|
|
|
|
|
&PL_sv_undef, 0); |
1713
|
|
|
|
|
|
/* note that unlike pp_entereval, pp_require isn't |
1714
|
|
|
|
|
|
* supposed to trap errors. So now that we've popped the |
1715
|
|
|
|
|
|
* EVAL that pp_require pushed, and processed the error |
1716
|
|
|
|
|
|
* message, rethrow the error */ |
1717
|
1796
|
50
|
|
|
|
Perl_croak(aTHX_ "%"SVf"Compilation failed in require", |
1718
|
|
|
|
|
|
SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n", |
1719
|
|
|
|
|
|
SVs_TEMP))); |
1720
|
|
|
|
|
|
} |
1721
|
317649
|
100
|
|
|
|
if (!(in_eval & EVAL_KEEPERR)) |
1722
|
317455
|
50
|
|
|
|
sv_setsv(ERRSV, exceptsv); |
1723
|
317649
|
|
|
|
|
PL_restartjmpenv = restartjmpenv; |
1724
|
317649
|
|
|
|
|
PL_restartop = restartop; |
1725
|
317649
|
50
|
|
|
|
JMPENV_JUMP(3); |
1726
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1727
|
|
|
|
|
|
} |
1728
|
|
|
|
|
|
} |
1729
|
|
|
|
|
|
|
1730
|
1090
|
|
|
|
|
write_to_stderr(exceptsv); |
1731
|
1088
|
|
|
|
|
my_failure_exit(); |
1732
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
1733
|
|
|
|
|
|
} |
1734
|
|
|
|
|
|
|
1735
|
108566
|
|
|
|
|
PP(pp_xor) |
1736
|
|
|
|
|
|
{ |
1737
|
108566
|
|
|
|
|
dVAR; dSP; dPOPTOPssrl; |
1738
|
108566
|
50
|
|
|
|
if (SvTRUE(left) != SvTRUE(right)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
1739
|
1018
|
|
|
|
|
RETSETYES; |
1740
|
|
|
|
|
|
else |
1741
|
108057
|
|
|
|
|
RETSETNO; |
1742
|
|
|
|
|
|
} |
1743
|
|
|
|
|
|
|
1744
|
|
|
|
|
|
/* |
1745
|
|
|
|
|
|
=for apidoc caller_cx |
1746
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
The XSUB-writer's equivalent of L. The |
1748
|
|
|
|
|
|
returned C structure can be interrogated to find all the |
1749
|
|
|
|
|
|
information returned to Perl by C. Note that XSUBs don't get a |
1750
|
|
|
|
|
|
stack frame, so C will return information for the |
1751
|
|
|
|
|
|
immediately-surrounding Perl code. |
1752
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
This function skips over the automatic calls to C<&DB::sub> made on the |
1754
|
|
|
|
|
|
behalf of the debugger. If the stack frame requested was a sub called by |
1755
|
|
|
|
|
|
C, the return value will be the frame for the call to |
1756
|
|
|
|
|
|
C, since that has the correct line number/etc. for the call |
1757
|
|
|
|
|
|
site. If I is non-C, it will be set to a pointer to the |
1758
|
|
|
|
|
|
frame for the sub call itself. |
1759
|
|
|
|
|
|
|
1760
|
|
|
|
|
|
=cut |
1761
|
|
|
|
|
|
*/ |
1762
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
const PERL_CONTEXT * |
1764
|
7740194
|
|
|
|
|
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) |
1765
|
|
|
|
|
|
{ |
1766
|
7740194
|
|
|
|
|
I32 cxix = dopoptosub(cxstack_ix); |
1767
|
|
|
|
|
|
const PERL_CONTEXT *cx; |
1768
|
7740194
|
|
|
|
|
const PERL_CONTEXT *ccstack = cxstack; |
1769
|
7740194
|
|
|
|
|
const PERL_SI *top_si = PL_curstackinfo; |
1770
|
|
|
|
|
|
|
1771
|
|
|
|
|
|
for (;;) { |
1772
|
|
|
|
|
|
/* we may be in a higher stacklevel, so dig down deeper */ |
1773
|
35786405
|
100
|
|
|
|
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { |
|
|
100
|
|
|
|
|
1774
|
5508
|
|
|
|
|
top_si = top_si->si_prev; |
1775
|
5508
|
|
|
|
|
ccstack = top_si->si_cxstack; |
1776
|
14026579
|
|
|
|
|
cxix = dopoptosub_at(ccstack, top_si->si_cxix); |
1777
|
|
|
|
|
|
} |
1778
|
35780897
|
100
|
|
|
|
if (cxix < 0) |
1779
|
|
|
|
|
|
return NULL; |
1780
|
|
|
|
|
|
/* caller() should not report the automatic calls to &DB::sub */ |
1781
|
35678439
|
100
|
|
|
|
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1782
|
56020
|
|
|
|
|
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) |
1783
|
16784
|
|
|
|
|
count++; |
1784
|
35650429
|
100
|
|
|
|
if (!count--) |
1785
|
|
|
|
|
|
break; |
1786
|
28040703
|
|
|
|
|
cxix = dopoptosub_at(ccstack, cxix - 1); |
1787
|
28040703
|
|
|
|
|
} |
1788
|
|
|
|
|
|
|
1789
|
7609726
|
|
|
|
|
cx = &ccstack[cxix]; |
1790
|
7609726
|
100
|
|
|
|
if (dbcxp) *dbcxp = cx; |
1791
|
|
|
|
|
|
|
1792
|
7609726
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
1793
|
7598978
|
|
|
|
|
const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); |
1794
|
|
|
|
|
|
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the |
1795
|
|
|
|
|
|
field below is defined for any cx. */ |
1796
|
|
|
|
|
|
/* caller() should not report the automatic calls to &DB::sub */ |
1797
|
7598978
|
100
|
|
|
|
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1798
|
1958
|
|
|
|
|
cx = &ccstack[dbcxix]; |
1799
|
|
|
|
|
|
} |
1800
|
|
|
|
|
|
|
1801
|
7674960
|
|
|
|
|
return cx; |
1802
|
|
|
|
|
|
} |
1803
|
|
|
|
|
|
|
1804
|
7739904
|
|
|
|
|
PP(pp_caller) |
1805
|
5368107
|
50
|
|
|
|
{ |
1806
|
|
|
|
|
|
dVAR; |
1807
|
7739904
|
|
|
|
|
dSP; |
1808
|
|
|
|
|
|
const PERL_CONTEXT *cx; |
1809
|
|
|
|
|
|
const PERL_CONTEXT *dbcx; |
1810
|
|
|
|
|
|
I32 gimme; |
1811
|
|
|
|
|
|
const HEK *stash_hek; |
1812
|
|
|
|
|
|
I32 count = 0; |
1813
|
7739904
|
100
|
|
|
|
bool has_arg = MAXARG && TOPs; |
|
|
100
|
|
|
|
|
1814
|
|
|
|
|
|
const COP *lcop; |
1815
|
|
|
|
|
|
|
1816
|
7739904
|
100
|
|
|
|
if (MAXARG) { |
1817
|
6109314
|
100
|
|
|
|
if (has_arg) |
1818
|
6109310
|
50
|
|
|
|
count = POPi; |
1819
|
4
|
|
|
|
|
else (void)POPs; |
1820
|
|
|
|
|
|
} |
1821
|
|
|
|
|
|
|
1822
|
7739904
|
|
|
|
|
cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx); |
1823
|
7739904
|
100
|
|
|
|
if (!cx) { |
1824
|
130628
|
50
|
|
|
|
if (GIMME != G_ARRAY) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1825
|
164
|
|
|
|
|
EXTEND(SP, 1); |
1826
|
328
|
|
|
|
|
RETPUSHUNDEF; |
1827
|
|
|
|
|
|
} |
1828
|
130136
|
|
|
|
|
RETURN; |
1829
|
|
|
|
|
|
} |
1830
|
|
|
|
|
|
|
1831
|
|
|
|
|
|
DEBUG_CX("CALLER"); |
1832
|
|
|
|
|
|
assert(CopSTASH(cx->blk_oldcop)); |
1833
|
7609440
|
|
|
|
|
stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV |
1834
|
15163738
|
50
|
|
|
|
? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) |
1835
|
22773178
|
100
|
|
|
|
: NULL; |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
1836
|
8705809
|
100
|
|
|
|
if (GIMME != G_ARRAY) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1837
|
1096369
|
|
|
|
|
EXTEND(SP, 1); |
1838
|
2241333
|
100
|
|
|
|
if (!stash_hek) |
1839
|
10
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1840
|
|
|
|
|
|
else { |
1841
|
2241323
|
|
|
|
|
dTARGET; |
1842
|
2241323
|
|
|
|
|
sv_sethek(TARG, stash_hek); |
1843
|
2241323
|
|
|
|
|
PUSHs(TARG); |
1844
|
|
|
|
|
|
} |
1845
|
2241333
|
|
|
|
|
RETURN; |
1846
|
|
|
|
|
|
} |
1847
|
|
|
|
|
|
|
1848
|
2680815
|
|
|
|
|
EXTEND(SP, 11); |
1849
|
|
|
|
|
|
|
1850
|
5368107
|
100
|
|
|
|
if (!stash_hek) |
1851
|
28
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1852
|
|
|
|
|
|
else { |
1853
|
5368079
|
|
|
|
|
dTARGET; |
1854
|
5368079
|
|
|
|
|
sv_sethek(TARG, stash_hek); |
1855
|
5368079
|
50
|
|
|
|
PUSHTARG; |
1856
|
|
|
|
|
|
} |
1857
|
5368107
|
50
|
|
|
|
mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); |
1858
|
5368107
|
|
|
|
|
lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling, |
1859
|
|
|
|
|
|
cx->blk_sub.retop, TRUE); |
1860
|
5368107
|
100
|
|
|
|
if (!lcop) |
1861
|
2016
|
|
|
|
|
lcop = cx->blk_oldcop; |
1862
|
5368107
|
|
|
|
|
mPUSHi((I32)CopLINE(lcop)); |
1863
|
5368107
|
100
|
|
|
|
if (!has_arg) |
1864
|
306960
|
|
|
|
|
RETURN; |
1865
|
5061147
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
1866
|
5056415
|
|
|
|
|
GV * const cvgv = CvGV(dbcx->blk_sub.cv); |
1867
|
|
|
|
|
|
/* So is ccstack[dbcxix]. */ |
1868
|
10112830
|
50
|
|
|
|
if (cvgv && isGV(cvgv)) { |
|
|
50
|
|
|
|
|
1869
|
5056415
|
|
|
|
|
SV * const sv = newSV(0); |
1870
|
5056415
|
|
|
|
|
gv_efullname3(sv, cvgv, NULL); |
1871
|
5056415
|
|
|
|
|
mPUSHs(sv); |
1872
|
5056415
|
100
|
|
|
|
PUSHs(boolSV(CxHASARGS(cx))); |
1873
|
|
|
|
|
|
} |
1874
|
|
|
|
|
|
else { |
1875
|
0
|
|
|
|
|
PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); |
1876
|
0
|
0
|
|
|
|
PUSHs(boolSV(CxHASARGS(cx))); |
1877
|
|
|
|
|
|
} |
1878
|
|
|
|
|
|
} |
1879
|
|
|
|
|
|
else { |
1880
|
4732
|
|
|
|
|
PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); |
1881
|
4732
|
|
|
|
|
mPUSHi(0); |
1882
|
|
|
|
|
|
} |
1883
|
5061147
|
|
|
|
|
gimme = (I32)cx->blk_gimme; |
1884
|
5061147
|
100
|
|
|
|
if (gimme == G_VOID) |
1885
|
3263545
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1886
|
|
|
|
|
|
else |
1887
|
1797602
|
100
|
|
|
|
PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); |
1888
|
5061147
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_EVAL) { |
1889
|
|
|
|
|
|
/* eval STRING */ |
1890
|
4732
|
100
|
|
|
|
if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { |
1891
|
396
|
|
|
|
|
PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), |
1892
|
|
|
|
|
|
SvCUR(cx->blk_eval.cur_text)-2, |
1893
|
|
|
|
|
|
SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); |
1894
|
396
|
|
|
|
|
PUSHs(&PL_sv_no); |
1895
|
|
|
|
|
|
} |
1896
|
|
|
|
|
|
/* require */ |
1897
|
4336
|
100
|
|
|
|
else if (cx->blk_eval.old_namesv) { |
1898
|
2728
|
|
|
|
|
mPUSHs(newSVsv(cx->blk_eval.old_namesv)); |
1899
|
2728
|
|
|
|
|
PUSHs(&PL_sv_yes); |
1900
|
|
|
|
|
|
} |
1901
|
|
|
|
|
|
/* eval BLOCK (try blocks have old_namesv == 0) */ |
1902
|
|
|
|
|
|
else { |
1903
|
1608
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1904
|
1608
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1905
|
|
|
|
|
|
} |
1906
|
|
|
|
|
|
} |
1907
|
|
|
|
|
|
else { |
1908
|
5056415
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1909
|
5056415
|
|
|
|
|
PUSHs(&PL_sv_undef); |
1910
|
|
|
|
|
|
} |
1911
|
5061147
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx) |
1912
|
5055807
|
100
|
|
|
|
&& CopSTASH_eq(PL_curcop, PL_debstash)) |
1913
|
|
|
|
|
|
{ |
1914
|
87344
|
|
|
|
|
AV * const ary = cx->blk_sub.argarray; |
1915
|
87344
|
|
|
|
|
const SSize_t off = AvARRAY(ary) - AvALLOC(ary); |
1916
|
|
|
|
|
|
|
1917
|
87344
|
|
|
|
|
Perl_init_dbargs(aTHX); |
1918
|
|
|
|
|
|
|
1919
|
87342
|
100
|
|
|
|
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) |
1920
|
422
|
|
|
|
|
av_extend(PL_dbargs, AvFILLp(ary) + off); |
1921
|
87342
|
50
|
|
|
|
Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); |
1922
|
87342
|
|
|
|
|
AvFILLp(PL_dbargs) = AvFILLp(ary) + off; |
1923
|
|
|
|
|
|
} |
1924
|
5061145
|
|
|
|
|
mPUSHi(CopHINTS_get(cx->blk_oldcop)); |
1925
|
|
|
|
|
|
{ |
1926
|
|
|
|
|
|
SV * mask ; |
1927
|
5061145
|
|
|
|
|
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; |
1928
|
|
|
|
|
|
|
1929
|
5061145
|
100
|
|
|
|
if (old_warnings == pWARN_NONE) |
1930
|
4708
|
|
|
|
|
mask = newSVpvn(WARN_NONEstring, WARNsize) ; |
1931
|
5056437
|
100
|
|
|
|
else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) |
|
|
100
|
|
|
|
|
1932
|
|
|
|
|
|
mask = &PL_sv_undef ; |
1933
|
4709954
|
100
|
|
|
|
else if (old_warnings == pWARN_ALL || |
|
|
100
|
|
|
|
|
1934
|
704620
|
50
|
|
|
|
(old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { |
1935
|
|
|
|
|
|
/* Get the bit mask for $warnings::Bits{all}, because |
1936
|
|
|
|
|
|
* it could have been extended by warnings::register */ |
1937
|
|
|
|
|
|
SV **bits_all; |
1938
|
2733372
|
|
|
|
|
HV * const bits = get_hv("warnings::Bits", 0); |
1939
|
2733372
|
100
|
|
|
|
if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { |
|
|
50
|
|
|
|
|
1940
|
2733072
|
|
|
|
|
mask = newSVsv(*bits_all); |
1941
|
|
|
|
|
|
} |
1942
|
|
|
|
|
|
else { |
1943
|
300
|
|
|
|
|
mask = newSVpvn(WARN_ALLstring, WARNsize) ; |
1944
|
|
|
|
|
|
} |
1945
|
|
|
|
|
|
} |
1946
|
|
|
|
|
|
else |
1947
|
1976582
|
|
|
|
|
mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); |
1948
|
5061145
|
|
|
|
|
mPUSHs(mask); |
1949
|
|
|
|
|
|
} |
1950
|
|
|
|
|
|
|
1951
|
5061145
|
100
|
|
|
|
PUSHs(cx->blk_oldcop->cop_hints_hash ? |
1952
|
|
|
|
|
|
sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) |
1953
|
|
|
|
|
|
: &PL_sv_undef); |
1954
|
6426980
|
|
|
|
|
RETURN; |
1955
|
|
|
|
|
|
} |
1956
|
|
|
|
|
|
|
1957
|
58
|
|
|
|
|
PP(pp_reset) |
1958
|
|
|
|
|
|
{ |
1959
|
|
|
|
|
|
dVAR; |
1960
|
58
|
|
|
|
|
dSP; |
1961
|
|
|
|
|
|
const char * tmps; |
1962
|
58
|
|
|
|
|
STRLEN len = 0; |
1963
|
58
|
100
|
|
|
|
if (MAXARG < 1 || (!TOPs && !POPs)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1964
|
26
|
|
|
|
|
tmps = NULL, len = 0; |
1965
|
|
|
|
|
|
else |
1966
|
32
|
100
|
|
|
|
tmps = SvPVx_const(POPs, len); |
1967
|
58
|
|
|
|
|
sv_resetpvn(tmps, len, CopSTASH(PL_curcop)); |
1968
|
58
|
|
|
|
|
PUSHs(&PL_sv_yes); |
1969
|
58
|
|
|
|
|
RETURN; |
1970
|
|
|
|
|
|
} |
1971
|
|
|
|
|
|
|
1972
|
|
|
|
|
|
/* like pp_nextstate, but used instead when the debugger is active */ |
1973
|
|
|
|
|
|
|
1974
|
762718
|
|
|
|
|
PP(pp_dbstate) |
1975
|
|
|
|
|
|
{ |
1976
|
|
|
|
|
|
dVAR; |
1977
|
762718
|
|
|
|
|
PL_curcop = (COP*)PL_op; |
1978
|
762718
|
|
|
|
|
TAINT_NOT; /* Each statement is presumed innocent */ |
1979
|
762718
|
|
|
|
|
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; |
1980
|
762718
|
100
|
|
|
|
FREETMPS; |
1981
|
|
|
|
|
|
|
1982
|
762718
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
1983
|
|
|
|
|
|
|
1984
|
2041645
|
100
|
|
|
|
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
1985
|
2041465
|
100
|
|
|
|
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) |
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1986
|
|
|
|
|
|
{ |
1987
|
|
|
|
|
|
dSP; |
1988
|
|
|
|
|
|
PERL_CONTEXT *cx; |
1989
|
|
|
|
|
|
const I32 gimme = G_ARRAY; |
1990
|
|
|
|
|
|
U8 hasargs; |
1991
|
329550
|
|
|
|
|
GV * const gv = PL_DBgv; |
1992
|
|
|
|
|
|
CV * cv = NULL; |
1993
|
|
|
|
|
|
|
1994
|
329550
|
50
|
|
|
|
if (gv && isGV_with_GP(gv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1995
|
329548
|
|
|
|
|
cv = GvCV(gv); |
1996
|
|
|
|
|
|
|
1997
|
329550
|
100
|
|
|
|
if (!cv || (!CvROOT(cv) && !CvXSUB(cv))) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1998
|
4
|
|
|
|
|
DIE(aTHX_ "No DB::DB routine defined"); |
1999
|
|
|
|
|
|
|
2000
|
329546
|
100
|
|
|
|
if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) |
|
|
100
|
|
|
|
|
2001
|
|
|
|
|
|
/* don't do recursive DB::DB call */ |
2002
|
327808
|
|
|
|
|
return NORMAL; |
2003
|
|
|
|
|
|
|
2004
|
1738
|
|
|
|
|
ENTER; |
2005
|
1738
|
|
|
|
|
SAVETMPS; |
2006
|
|
|
|
|
|
|
2007
|
1738
|
|
|
|
|
SAVEI32(PL_debug); |
2008
|
1738
|
50
|
|
|
|
SAVESTACK_POS(); |
2009
|
1738
|
|
|
|
|
PL_debug = 0; |
2010
|
|
|
|
|
|
hasargs = 0; |
2011
|
1738
|
|
|
|
|
SPAGAIN; |
2012
|
|
|
|
|
|
|
2013
|
1738
|
50
|
|
|
|
if (CvISXSUB(cv)) { |
2014
|
0
|
0
|
|
|
|
PUSHMARK(SP); |
2015
|
0
|
|
|
|
|
(void)(*CvXSUB(cv))(aTHX_ cv); |
2016
|
0
|
0
|
|
|
|
FREETMPS; |
2017
|
0
|
|
|
|
|
LEAVE; |
2018
|
0
|
|
|
|
|
return NORMAL; |
2019
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
else { |
2021
|
1738
|
50
|
|
|
|
PUSHBLOCK(cx, CXt_SUB, SP); |
2022
|
3476
|
100
|
|
|
|
PUSHSUB_DB(cx); |
2023
|
1738
|
|
|
|
|
cx->blk_sub.retop = PL_op->op_next; |
2024
|
1738
|
|
|
|
|
CvDEPTH(cv)++; |
2025
|
1738
|
100
|
|
|
|
if (CvDEPTH(cv) >= 2) { |
2026
|
|
|
|
|
|
PERL_STACK_OVERFLOW_CHECK(); |
2027
|
42
|
|
|
|
|
pad_push(CvPADLIST(cv), CvDEPTH(cv)); |
2028
|
|
|
|
|
|
} |
2029
|
1738
|
|
|
|
|
SAVECOMPPAD(); |
2030
|
3476
|
|
|
|
|
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); |
2031
|
1738
|
|
|
|
|
RETURNOP(CvSTART(cv)); |
2032
|
|
|
|
|
|
} |
2033
|
|
|
|
|
|
} |
2034
|
|
|
|
|
|
else |
2035
|
597941
|
|
|
|
|
return NORMAL; |
2036
|
|
|
|
|
|
} |
2037
|
|
|
|
|
|
|
2038
|
|
|
|
|
|
STATIC SV ** |
2039
|
298501413
|
|
|
|
|
S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) |
2040
|
|
|
|
|
|
{ |
2041
|
|
|
|
|
|
bool padtmp = 0; |
2042
|
|
|
|
|
|
PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; |
2043
|
|
|
|
|
|
|
2044
|
298501413
|
100
|
|
|
|
if (flags & SVs_PADTMP) { |
2045
|
232049933
|
|
|
|
|
flags &= ~SVs_PADTMP; |
2046
|
|
|
|
|
|
padtmp = 1; |
2047
|
|
|
|
|
|
} |
2048
|
298501413
|
100
|
|
|
|
if (gimme == G_SCALAR) { |
2049
|
35516265
|
100
|
|
|
|
if (MARK < SP) |
2050
|
75966088
|
100
|
|
|
|
*++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP))) |
|
|
100
|
|
|
|
|
2051
|
56790144
|
100
|
|
|
|
? *SP : sv_mortalcopy(*SP); |
2052
|
|
|
|
|
|
else { |
2053
|
|
|
|
|
|
/* MEXTEND() only updates MARK, so reuse it instead of newsp. */ |
2054
|
|
|
|
|
|
MARK = newsp; |
2055
|
34
|
50
|
|
|
|
MEXTEND(MARK, 1); |
2056
|
34
|
|
|
|
|
*++MARK = &PL_sv_undef; |
2057
|
34
|
|
|
|
|
return MARK; |
2058
|
|
|
|
|
|
} |
2059
|
|
|
|
|
|
} |
2060
|
262985148
|
100
|
|
|
|
else if (gimme == G_ARRAY) { |
2061
|
|
|
|
|
|
/* in case LEAVE wipes old return values */ |
2062
|
64092312
|
100
|
|
|
|
while (++MARK <= SP) { |
2063
|
32088378
|
100
|
|
|
|
if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK))) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2064
|
1565334
|
|
|
|
|
*++newsp = *MARK; |
2065
|
|
|
|
|
|
else { |
2066
|
30523044
|
|
|
|
|
*++newsp = sv_mortalcopy(*MARK); |
2067
|
31305711
|
|
|
|
|
TAINT_NOT; /* Each item is independent */ |
2068
|
|
|
|
|
|
} |
2069
|
|
|
|
|
|
} |
2070
|
|
|
|
|
|
/* When this function was called with MARK == newsp, we reach this |
2071
|
|
|
|
|
|
* point with SP == newsp. */ |
2072
|
|
|
|
|
|
} |
2073
|
|
|
|
|
|
|
2074
|
298501396
|
|
|
|
|
return newsp; |
2075
|
|
|
|
|
|
} |
2076
|
|
|
|
|
|
|
2077
|
247293224
|
|
|
|
|
PP(pp_enter) |
2078
|
|
|
|
|
|
{ |
2079
|
247293224
|
|
|
|
|
dVAR; dSP; |
2080
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2081
|
247293224
|
100
|
|
|
|
I32 gimme = GIMME_V; |
2082
|
|
|
|
|
|
|
2083
|
247293224
|
|
|
|
|
ENTER_with_name("block"); |
2084
|
|
|
|
|
|
|
2085
|
247293224
|
|
|
|
|
SAVETMPS; |
2086
|
247293224
|
100
|
|
|
|
PUSHBLOCK(cx, CXt_BLOCK, SP); |
2087
|
|
|
|
|
|
|
2088
|
247293224
|
|
|
|
|
RETURN; |
2089
|
|
|
|
|
|
} |
2090
|
|
|
|
|
|
|
2091
|
216866177
|
|
|
|
|
PP(pp_leave) |
2092
|
|
|
|
|
|
{ |
2093
|
216866177
|
|
|
|
|
dVAR; dSP; |
2094
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2095
|
|
|
|
|
|
SV **newsp; |
2096
|
|
|
|
|
|
PMOP *newpm; |
2097
|
|
|
|
|
|
I32 gimme; |
2098
|
|
|
|
|
|
|
2099
|
216866177
|
100
|
|
|
|
if (PL_op->op_flags & OPf_SPECIAL) { |
2100
|
2975396
|
|
|
|
|
cx = &cxstack[cxstack_ix]; |
2101
|
2975396
|
|
|
|
|
cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ |
2102
|
|
|
|
|
|
} |
2103
|
|
|
|
|
|
|
2104
|
216866177
|
|
|
|
|
POPBLOCK(cx,newpm); |
2105
|
|
|
|
|
|
|
2106
|
216866177
|
100
|
|
|
|
gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); |
|
|
50
|
|
|
|
|
2107
|
|
|
|
|
|
|
2108
|
216866177
|
|
|
|
|
TAINT_NOT; |
2109
|
216866177
|
|
|
|
|
SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); |
2110
|
216866177
|
|
|
|
|
PL_curpm = newpm; /* Don't pop $1 et al till now */ |
2111
|
|
|
|
|
|
|
2112
|
216866177
|
|
|
|
|
LEAVE_with_name("block"); |
2113
|
|
|
|
|
|
|
2114
|
216866177
|
|
|
|
|
RETURN; |
2115
|
|
|
|
|
|
} |
2116
|
|
|
|
|
|
|
2117
|
30822110
|
|
|
|
|
PP(pp_enteriter) |
2118
|
|
|
|
|
|
{ |
2119
|
30822110
|
|
|
|
|
dVAR; dSP; dMARK; |
2120
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2121
|
30822110
|
50
|
|
|
|
const I32 gimme = GIMME_V; |
2122
|
|
|
|
|
|
void *itervar; /* location of the iteration variable */ |
2123
|
|
|
|
|
|
U8 cxtype = CXt_LOOP_FOR; |
2124
|
|
|
|
|
|
|
2125
|
30822110
|
|
|
|
|
ENTER_with_name("loop1"); |
2126
|
30822110
|
|
|
|
|
SAVETMPS; |
2127
|
|
|
|
|
|
|
2128
|
30822110
|
100
|
|
|
|
if (PL_op->op_targ) { /* "my" variable */ |
2129
|
13745172
|
100
|
|
|
|
if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ |
2130
|
12887603
|
|
|
|
|
SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); |
2131
|
12887603
|
|
|
|
|
SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), |
2132
|
|
|
|
|
|
SVs_PADSTALE, SVs_PADSTALE); |
2133
|
|
|
|
|
|
} |
2134
|
13745172
|
|
|
|
|
SAVEPADSVANDMORTALIZE(PL_op->op_targ); |
2135
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2136
|
|
|
|
|
|
itervar = PL_comppad; |
2137
|
|
|
|
|
|
#else |
2138
|
13745172
|
|
|
|
|
itervar = &PAD_SVl(PL_op->op_targ); |
2139
|
|
|
|
|
|
#endif |
2140
|
|
|
|
|
|
} |
2141
|
|
|
|
|
|
else { /* symbol table variable */ |
2142
|
17076938
|
|
|
|
|
GV * const gv = MUTABLE_GV(POPs); |
2143
|
17076938
|
|
|
|
|
SV** svp = &GvSV(gv); |
2144
|
25598490
|
|
|
|
|
save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV); |
2145
|
17076938
|
|
|
|
|
*svp = newSV(0); |
2146
|
|
|
|
|
|
itervar = (void *)gv; |
2147
|
|
|
|
|
|
} |
2148
|
|
|
|
|
|
|
2149
|
30822110
|
100
|
|
|
|
if (PL_op->op_private & OPpITER_DEF) |
2150
|
|
|
|
|
|
cxtype |= CXp_FOR_DEF; |
2151
|
|
|
|
|
|
|
2152
|
30822110
|
|
|
|
|
ENTER_with_name("loop2"); |
2153
|
|
|
|
|
|
|
2154
|
30822110
|
50
|
|
|
|
PUSHBLOCK(cx, cxtype, SP); |
2155
|
30822110
|
|
|
|
|
PUSHLOOP_FOR(cx, itervar, MARK); |
2156
|
30822110
|
100
|
|
|
|
if (PL_op->op_flags & OPf_STACKED) { |
2157
|
8297864
|
|
|
|
|
SV *maybe_ary = POPs; |
2158
|
8918253
|
100
|
|
|
|
if (SvTYPE(maybe_ary) != SVt_PVAV) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2159
|
620746
|
|
|
|
|
dPOPss; |
2160
|
|
|
|
|
|
SV * const right = maybe_ary; |
2161
|
310199
|
|
|
|
|
SvGETMAGIC(sv); |
2162
|
310201
|
|
|
|
|
SvGETMAGIC(right); |
2163
|
620746
|
100
|
|
|
|
if (RANGE_IS_NUMERIC(sv,right)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2164
|
620686
|
|
|
|
|
cx->cx_type &= ~CXTYPEMASK; |
2165
|
620686
|
|
|
|
|
cx->cx_type |= CXt_LOOP_LAZYIV; |
2166
|
|
|
|
|
|
/* Make sure that no-one re-orders cop.h and breaks our |
2167
|
|
|
|
|
|
assumptions */ |
2168
|
|
|
|
|
|
assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); |
2169
|
|
|
|
|
|
#ifdef NV_PRESERVES_UV |
2170
|
|
|
|
|
|
if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) || |
2171
|
|
|
|
|
|
(SvNV_nomg(sv) > (NV)IV_MAX))) |
2172
|
|
|
|
|
|
|| |
2173
|
|
|
|
|
|
(SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) || |
2174
|
|
|
|
|
|
(SvNV_nomg(right) < (NV)IV_MIN)))) |
2175
|
|
|
|
|
|
#else |
2176
|
3990555
|
100
|
|
|
|
if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2177
|
620606
|
100
|
|
|
|
|| |
2178
|
977688
|
100
|
|
|
|
((SvNV_nomg(sv) > 0) && |
|
|
100
|
|
|
|
|
2179
|
714308
|
0
|
|
|
|
((SvUV_nomg(sv) > (UV)IV_MAX) || |
|
|
50
|
|
|
|
|
2180
|
357001
|
50
|
|
|
|
(SvNV_nomg(sv) > (NV)UV_MAX))))) |
2181
|
620668
|
100
|
|
|
|
|| |
2182
|
765891
|
50
|
|
|
|
(SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2183
|
620608
|
100
|
|
|
|
|| |
2184
|
1171935
|
100
|
|
|
|
((SvNV_nomg(right) > 0) && |
|
|
100
|
|
|
|
|
2185
|
1103442
|
100
|
|
|
|
((SvUV_nomg(right) > (UV)IV_MAX) || |
|
|
50
|
|
|
|
|
2186
|
551497
|
50
|
|
|
|
(SvNV_nomg(right) > (NV)UV_MAX)) |
2187
|
|
|
|
|
|
)))) |
2188
|
|
|
|
|
|
#endif |
2189
|
36
|
|
|
|
|
DIE(aTHX_ "Range iterator outside integer range"); |
2190
|
620650
|
100
|
|
|
|
cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); |
2191
|
620650
|
100
|
|
|
|
cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); |
2192
|
|
|
|
|
|
#ifdef DEBUGGING |
2193
|
|
|
|
|
|
/* for correct -Dstv display */ |
2194
|
|
|
|
|
|
cx->blk_oldsp = sp - PL_stack_base; |
2195
|
|
|
|
|
|
#endif |
2196
|
|
|
|
|
|
} |
2197
|
|
|
|
|
|
else { |
2198
|
60
|
|
|
|
|
cx->cx_type &= ~CXTYPEMASK; |
2199
|
60
|
|
|
|
|
cx->cx_type |= CXt_LOOP_LAZYSV; |
2200
|
|
|
|
|
|
/* Make sure that no-one re-orders cop.h and breaks our |
2201
|
|
|
|
|
|
assumptions */ |
2202
|
|
|
|
|
|
assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); |
2203
|
60
|
|
|
|
|
cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); |
2204
|
60
|
|
|
|
|
cx->blk_loop.state_u.lazysv.end = right; |
2205
|
|
|
|
|
|
SvREFCNT_inc(right); |
2206
|
60
|
100
|
|
|
|
(void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); |
2207
|
|
|
|
|
|
/* This will do the upgrade to SVt_PV, and warn if the value |
2208
|
|
|
|
|
|
is uninitialised. */ |
2209
|
60
|
100
|
|
|
|
(void) SvPV_nolen_const(right); |
2210
|
|
|
|
|
|
/* Doing this avoids a check every time in pp_iter in pp_hot.c |
2211
|
|
|
|
|
|
to replace !SvOK() with a pointer to "". */ |
2212
|
60
|
100
|
|
|
|
if (!SvOK(right)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2213
|
6
|
|
|
|
|
SvREFCNT_dec(right); |
2214
|
6
|
|
|
|
|
cx->blk_loop.state_u.lazysv.end = &PL_sv_no; |
2215
|
|
|
|
|
|
} |
2216
|
|
|
|
|
|
} |
2217
|
|
|
|
|
|
} |
2218
|
|
|
|
|
|
else /* SvTYPE(maybe_ary) == SVt_PVAV */ { |
2219
|
7677118
|
|
|
|
|
cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); |
2220
|
|
|
|
|
|
SvREFCNT_inc(maybe_ary); |
2221
|
7677118
|
|
|
|
|
cx->blk_loop.state_u.ary.ix = |
2222
|
7677118
|
|
|
|
|
(PL_op->op_private & OPpITER_REVERSED) ? |
2223
|
7677118
|
100
|
|
|
|
AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : |
|
|
50
|
|
|
|
|
2224
|
|
|
|
|
|
-1; |
2225
|
|
|
|
|
|
} |
2226
|
|
|
|
|
|
} |
2227
|
|
|
|
|
|
else { /* iterating over items on the stack */ |
2228
|
22524246
|
|
|
|
|
cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ |
2229
|
22524246
|
100
|
|
|
|
if (PL_op->op_private & OPpITER_REVERSED) { |
2230
|
7262
|
|
|
|
|
cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; |
2231
|
|
|
|
|
|
} |
2232
|
|
|
|
|
|
else { |
2233
|
22516984
|
|
|
|
|
cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; |
2234
|
|
|
|
|
|
} |
2235
|
|
|
|
|
|
} |
2236
|
|
|
|
|
|
|
2237
|
30822074
|
|
|
|
|
RETURN; |
2238
|
|
|
|
|
|
} |
2239
|
|
|
|
|
|
|
2240
|
35267572
|
|
|
|
|
PP(pp_enterloop) |
2241
|
|
|
|
|
|
{ |
2242
|
35267572
|
|
|
|
|
dVAR; dSP; |
2243
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2244
|
35267572
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
2245
|
|
|
|
|
|
|
2246
|
35267572
|
|
|
|
|
ENTER_with_name("loop1"); |
2247
|
35267572
|
|
|
|
|
SAVETMPS; |
2248
|
35267572
|
|
|
|
|
ENTER_with_name("loop2"); |
2249
|
|
|
|
|
|
|
2250
|
35267572
|
100
|
|
|
|
PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); |
2251
|
35267572
|
|
|
|
|
PUSHLOOP_PLAIN(cx, SP); |
2252
|
|
|
|
|
|
|
2253
|
35267572
|
|
|
|
|
RETURN; |
2254
|
|
|
|
|
|
} |
2255
|
|
|
|
|
|
|
2256
|
60118060
|
|
|
|
|
PP(pp_leaveloop) |
2257
|
|
|
|
|
|
{ |
2258
|
60118060
|
|
|
|
|
dVAR; dSP; |
2259
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2260
|
|
|
|
|
|
I32 gimme; |
2261
|
|
|
|
|
|
SV **newsp; |
2262
|
|
|
|
|
|
PMOP *newpm; |
2263
|
|
|
|
|
|
SV **mark; |
2264
|
|
|
|
|
|
|
2265
|
60118060
|
|
|
|
|
POPBLOCK(cx,newpm); |
2266
|
|
|
|
|
|
assert(CxTYPE_is_LOOP(cx)); |
2267
|
|
|
|
|
|
mark = newsp; |
2268
|
60118060
|
|
|
|
|
newsp = PL_stack_base + cx->blk_loop.resetsp; |
2269
|
|
|
|
|
|
|
2270
|
60118060
|
|
|
|
|
TAINT_NOT; |
2271
|
60118060
|
|
|
|
|
SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0); |
2272
|
60118060
|
|
|
|
|
PUTBACK; |
2273
|
|
|
|
|
|
|
2274
|
60118060
|
100
|
|
|
|
POPLOOP(cx); /* Stack values are safe: release loop vars ... */ |
|
|
100
|
|
|
|
|
2275
|
60118060
|
|
|
|
|
PL_curpm = newpm; /* ... and pop $1 et al */ |
2276
|
|
|
|
|
|
|
2277
|
60118060
|
|
|
|
|
LEAVE_with_name("loop2"); |
2278
|
60118060
|
|
|
|
|
LEAVE_with_name("loop1"); |
2279
|
|
|
|
|
|
|
2280
|
60118060
|
|
|
|
|
return NORMAL; |
2281
|
|
|
|
|
|
} |
2282
|
|
|
|
|
|
|
2283
|
|
|
|
|
|
STATIC void |
2284
|
1600
|
|
|
|
|
S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, |
2285
|
|
|
|
|
|
PERL_CONTEXT *cx, PMOP *newpm) |
2286
|
|
|
|
|
|
{ |
2287
|
1600
|
|
|
|
|
const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); |
2288
|
1600
|
100
|
|
|
|
if (gimme == G_SCALAR) { |
2289
|
1158
|
100
|
|
|
|
if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ |
|
|
100
|
|
|
|
|
2290
|
|
|
|
|
|
SV *sv; |
2291
|
|
|
|
|
|
const char *what = NULL; |
2292
|
540
|
100
|
|
|
|
if (MARK < SP) { |
2293
|
|
|
|
|
|
assert(MARK+1 == SP); |
2294
|
801
|
100
|
|
|
|
if ((SvPADTMP(TOPs) || |
|
|
100
|
|
|
|
|
2295
|
530
|
|
|
|
|
(SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) |
2296
|
|
|
|
|
|
== SVf_READONLY |
2297
|
14
|
50
|
|
|
|
) && |
2298
|
14
|
|
|
|
|
!SvSMAGICAL(TOPs)) { |
2299
|
|
|
|
|
|
what = |
2300
|
24
|
|
|
|
|
SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" |
2301
|
19
|
100
|
|
|
|
: "a readonly value" : "a temporary"; |
|
|
100
|
|
|
|
|
2302
|
|
|
|
|
|
} |
2303
|
|
|
|
|
|
else goto copy_sv; |
2304
|
|
|
|
|
|
} |
2305
|
|
|
|
|
|
else { |
2306
|
|
|
|
|
|
/* sub:lvalue{} will take us here. */ |
2307
|
|
|
|
|
|
what = "undef"; |
2308
|
|
|
|
|
|
} |
2309
|
18
|
|
|
|
|
LEAVE; |
2310
|
18
|
|
|
|
|
cxstack_ix--; |
2311
|
27
|
50
|
|
|
|
POPSUB(cx,sv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2312
|
18
|
|
|
|
|
PL_curpm = newpm; |
2313
|
18
|
|
|
|
|
LEAVESUB(sv); |
2314
|
18
|
|
|
|
|
Perl_croak(aTHX_ |
2315
|
|
|
|
|
|
"Can't return %s from lvalue subroutine", what |
2316
|
|
|
|
|
|
); |
2317
|
|
|
|
|
|
} |
2318
|
618
|
50
|
|
|
|
if (MARK < SP) { |
|
|
0
|
|
|
|
|
2319
|
|
|
|
|
|
copy_sv: |
2320
|
1710
|
50
|
|
|
|
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { |
|
|
100
|
|
|
|
|
2321
|
14
|
100
|
|
|
|
if (!SvPADTMP(*SP)) { |
2322
|
20
|
|
|
|
|
*++newsp = SvREFCNT_inc(*SP); |
2323
|
10
|
100
|
|
|
|
FREETMPS; |
2324
|
10
|
|
|
|
|
sv_2mortal(*newsp); |
2325
|
|
|
|
|
|
} |
2326
|
|
|
|
|
|
else { |
2327
|
|
|
|
|
|
/* FREETMPS could clobber it */ |
2328
|
4
|
|
|
|
|
SV *sv = SvREFCNT_inc(*SP); |
2329
|
4
|
50
|
|
|
|
FREETMPS; |
2330
|
4
|
|
|
|
|
*++newsp = sv_mortalcopy(sv); |
2331
|
4
|
|
|
|
|
SvREFCNT_dec(sv); |
2332
|
|
|
|
|
|
} |
2333
|
|
|
|
|
|
} |
2334
|
|
|
|
|
|
else |
2335
|
1689
|
|
|
|
|
*++newsp = |
2336
|
1126
|
|
|
|
|
SvPADTMP(*SP) |
2337
|
238
|
|
|
|
|
? sv_mortalcopy(*SP) |
2338
|
1245
|
100
|
|
|
|
: !SvTEMP(*SP) |
2339
|
798
|
|
|
|
|
? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) |
2340
|
1287
|
100
|
|
|
|
: *SP; |
2341
|
|
|
|
|
|
} |
2342
|
|
|
|
|
|
else { |
2343
|
0
|
|
|
|
|
EXTEND(newsp,1); |
2344
|
0
|
|
|
|
|
*++newsp = &PL_sv_undef; |
2345
|
|
|
|
|
|
} |
2346
|
1152
|
100
|
|
|
|
if (CxLVAL(cx) & OPpDEREF) { |
|
|
50
|
|
|
|
|
2347
|
12
|
|
|
|
|
SvGETMAGIC(TOPs); |
2348
|
24
|
50
|
|
|
|
if (!SvOK(TOPs)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2349
|
24
|
|
|
|
|
TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF); |
2350
|
|
|
|
|
|
} |
2351
|
|
|
|
|
|
} |
2352
|
|
|
|
|
|
} |
2353
|
442
|
100
|
|
|
|
else if (gimme == G_ARRAY) { |
2354
|
|
|
|
|
|
assert (!(CxLVAL(cx) & OPpDEREF)); |
2355
|
360
|
100
|
|
|
|
if (ref || !CxLVAL(cx)) |
|
|
100
|
|
|
|
|
2356
|
728
|
100
|
|
|
|
while (++MARK <= SP) |
2357
|
636
|
|
|
|
|
*++newsp = |
2358
|
424
|
|
|
|
|
SvFLAGS(*MARK) & SVs_PADTMP |
2359
|
88
|
|
|
|
|
? sv_mortalcopy(*MARK) |
2360
|
468
|
100
|
|
|
|
: SvTEMP(*MARK) |
2361
|
|
|
|
|
|
? *MARK |
2362
|
336
|
100
|
|
|
|
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); |
2363
|
104
|
100
|
|
|
|
else while (++MARK <= SP) { |
2364
|
56
|
100
|
|
|
|
if (*MARK != &PL_sv_undef |
2365
|
50
|
100
|
|
|
|
&& (SvPADTMP(*MARK) |
2366
|
46
|
100
|
|
|
|
|| (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE)) |
2367
|
|
|
|
|
|
== SVf_READONLY |
2368
|
|
|
|
|
|
) |
2369
|
|
|
|
|
|
) { |
2370
|
|
|
|
|
|
SV *sv; |
2371
|
|
|
|
|
|
/* Might be flattened array after $#array = */ |
2372
|
8
|
|
|
|
|
PUTBACK; |
2373
|
8
|
|
|
|
|
LEAVE; |
2374
|
8
|
|
|
|
|
cxstack_ix--; |
2375
|
12
|
50
|
|
|
|
POPSUB(cx,sv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2376
|
8
|
|
|
|
|
PL_curpm = newpm; |
2377
|
8
|
|
|
|
|
LEAVESUB(sv); |
2378
|
|
|
|
|
|
/* diag_listed_as: Can't return %s from lvalue subroutine */ |
2379
|
8
|
100
|
|
|
|
Perl_croak(aTHX_ |
2380
|
|
|
|
|
|
"Can't return a %s from lvalue subroutine", |
2381
|
8
|
|
|
|
|
SvREADONLY(TOPs) ? "readonly value" : "temporary"); |
2382
|
|
|
|
|
|
} |
2383
|
|
|
|
|
|
else |
2384
|
72
|
|
|
|
|
*++newsp = |
2385
|
48
|
|
|
|
|
SvTEMP(*MARK) |
2386
|
|
|
|
|
|
? *MARK |
2387
|
48
|
50
|
|
|
|
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); |
2388
|
|
|
|
|
|
} |
2389
|
|
|
|
|
|
} |
2390
|
1574
|
|
|
|
|
PL_stack_sp = newsp; |
2391
|
1574
|
|
|
|
|
} |
2392
|
|
|
|
|
|
|
2393
|
242741932
|
|
|
|
|
PP(pp_return) |
2394
|
|
|
|
|
|
{ |
2395
|
242741932
|
|
|
|
|
dVAR; dSP; dMARK; |
2396
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2397
|
|
|
|
|
|
bool popsub2 = FALSE; |
2398
|
|
|
|
|
|
bool clear_errsv = FALSE; |
2399
|
|
|
|
|
|
bool lval = FALSE; |
2400
|
|
|
|
|
|
I32 gimme; |
2401
|
|
|
|
|
|
SV **newsp; |
2402
|
|
|
|
|
|
PMOP *newpm; |
2403
|
|
|
|
|
|
I32 optype = 0; |
2404
|
|
|
|
|
|
SV *namesv; |
2405
|
|
|
|
|
|
SV *sv; |
2406
|
|
|
|
|
|
OP *retop = NULL; |
2407
|
|
|
|
|
|
|
2408
|
242741932
|
|
|
|
|
const I32 cxix = dopoptosub(cxstack_ix); |
2409
|
|
|
|
|
|
|
2410
|
242741932
|
100
|
|
|
|
if (cxix < 0) { |
2411
|
13662
|
50
|
|
|
|
if (CxMULTICALL(cxstack)) { /* In this case we must be in a |
2412
|
|
|
|
|
|
* sort block, which is a CXt_NULL |
2413
|
|
|
|
|
|
* not a CXt_SUB */ |
2414
|
13662
|
|
|
|
|
dounwind(0); |
2415
|
13662
|
|
|
|
|
PL_stack_base[1] = *PL_stack_sp; |
2416
|
13662
|
|
|
|
|
PL_stack_sp = PL_stack_base + 1; |
2417
|
13662
|
|
|
|
|
return 0; |
2418
|
|
|
|
|
|
} |
2419
|
|
|
|
|
|
else |
2420
|
0
|
|
|
|
|
DIE(aTHX_ "Can't return outside a subroutine"); |
2421
|
|
|
|
|
|
} |
2422
|
242728270
|
100
|
|
|
|
if (cxix < cxstack_ix) |
2423
|
19304455
|
|
|
|
|
dounwind(cxix); |
2424
|
|
|
|
|
|
|
2425
|
242728270
|
100
|
|
|
|
if (CxMULTICALL(&cxstack[cxix])) { |
2426
|
34926
|
|
|
|
|
gimme = cxstack[cxix].blk_gimme; |
2427
|
34926
|
50
|
|
|
|
if (gimme == G_VOID) |
2428
|
0
|
|
|
|
|
PL_stack_sp = PL_stack_base; |
2429
|
34926
|
50
|
|
|
|
else if (gimme == G_SCALAR) { |
2430
|
34926
|
|
|
|
|
PL_stack_base[1] = *PL_stack_sp; |
2431
|
34926
|
|
|
|
|
PL_stack_sp = PL_stack_base + 1; |
2432
|
|
|
|
|
|
} |
2433
|
|
|
|
|
|
return 0; |
2434
|
|
|
|
|
|
} |
2435
|
|
|
|
|
|
|
2436
|
242693344
|
|
|
|
|
POPBLOCK(cx,newpm); |
2437
|
242693344
|
|
|
|
|
switch (CxTYPE(cx)) { |
2438
|
|
|
|
|
|
case CXt_SUB: |
2439
|
|
|
|
|
|
popsub2 = TRUE; |
2440
|
242683650
|
|
|
|
|
lval = !!CvLVALUE(cx->blk_sub.cv); |
2441
|
242683650
|
|
|
|
|
retop = cx->blk_sub.retop; |
2442
|
242683650
|
|
|
|
|
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ |
2443
|
242683650
|
|
|
|
|
break; |
2444
|
|
|
|
|
|
case CXt_EVAL: |
2445
|
9630
|
50
|
|
|
|
if (!(PL_in_eval & EVAL_KEEPERR)) |
2446
|
|
|
|
|
|
clear_errsv = TRUE; |
2447
|
9630
|
100
|
|
|
|
POPEVAL(cx); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2448
|
9630
|
|
|
|
|
namesv = cx->blk_eval.old_namesv; |
2449
|
9630
|
|
|
|
|
retop = cx->blk_eval.retop; |
2450
|
9630
|
100
|
|
|
|
if (CxTRYBLOCK(cx)) |
2451
|
|
|
|
|
|
break; |
2452
|
9647
|
100
|
|
|
|
if (optype == OP_REQUIRE && |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2453
|
32
|
50
|
|
|
|
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
2454
|
|
|
|
|
|
{ |
2455
|
|
|
|
|
|
/* Unassume the success we assumed earlier. */ |
2456
|
0
|
0
|
|
|
|
(void)hv_delete(GvHVn(PL_incgv), |
|
|
0
|
|
|
|
|
2457
|
|
|
|
|
|
SvPVX_const(namesv), |
2458
|
|
|
|
|
|
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), |
2459
|
|
|
|
|
|
G_DISCARD); |
2460
|
0
|
|
|
|
|
DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); |
2461
|
|
|
|
|
|
} |
2462
|
|
|
|
|
|
break; |
2463
|
|
|
|
|
|
case CXt_FORMAT: |
2464
|
64
|
|
|
|
|
retop = cx->blk_sub.retop; |
2465
|
96
|
50
|
|
|
|
POPFORMAT(cx); |
|
|
50
|
|
|
|
|
2466
|
64
|
|
|
|
|
break; |
2467
|
|
|
|
|
|
default: |
2468
|
0
|
|
|
|
|
DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); |
2469
|
|
|
|
|
|
} |
2470
|
|
|
|
|
|
|
2471
|
242693344
|
|
|
|
|
TAINT_NOT; |
2472
|
242693344
|
100
|
|
|
|
if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm); |
2473
|
|
|
|
|
|
else { |
2474
|
242693178
|
100
|
|
|
|
if (gimme == G_SCALAR) { |
2475
|
202009446
|
100
|
|
|
|
if (MARK < SP) { |
2476
|
189173474
|
100
|
|
|
|
if (popsub2) { |
2477
|
283736623
|
50
|
|
|
|
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { |
|
|
100
|
|
|
|
|
2478
|
30841704
|
100
|
|
|
|
if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1 |
2479
|
20561136
|
|
|
|
|
&& !SvMAGICAL(TOPs)) { |
2480
|
18878088
|
|
|
|
|
*++newsp = SvREFCNT_inc(*SP); |
2481
|
9439044
|
50
|
|
|
|
FREETMPS; |
2482
|
9439044
|
|
|
|
|
sv_2mortal(*newsp); |
2483
|
|
|
|
|
|
} |
2484
|
|
|
|
|
|
else { |
2485
|
11122092
|
|
|
|
|
sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ |
2486
|
11122092
|
100
|
|
|
|
FREETMPS; |
2487
|
11122092
|
|
|
|
|
*++newsp = sv_mortalcopy(sv); |
2488
|
11122092
|
|
|
|
|
SvREFCNT_dec(sv); |
2489
|
|
|
|
|
|
} |
2490
|
|
|
|
|
|
} |
2491
|
252894919
|
100
|
|
|
|
else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1 |
2492
|
168602750
|
|
|
|
|
&& !SvMAGICAL(*SP)) { |
2493
|
15533618
|
|
|
|
|
*++newsp = *SP; |
2494
|
|
|
|
|
|
} |
2495
|
|
|
|
|
|
else |
2496
|
153069132
|
|
|
|
|
*++newsp = sv_mortalcopy(*SP); |
2497
|
|
|
|
|
|
} |
2498
|
|
|
|
|
|
else |
2499
|
9588
|
|
|
|
|
*++newsp = sv_mortalcopy(*SP); |
2500
|
|
|
|
|
|
} |
2501
|
|
|
|
|
|
else |
2502
|
12835972
|
|
|
|
|
*++newsp = &PL_sv_undef; |
2503
|
|
|
|
|
|
} |
2504
|
40683732
|
100
|
|
|
|
else if (gimme == G_ARRAY) { |
2505
|
45802312
|
100
|
|
|
|
while (++MARK <= SP) { |
2506
|
85091069
|
|
|
|
|
*++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1 |
2507
|
28363691
|
100
|
|
|
|
&& !SvGMAGICAL(*MARK) |
2508
|
44502568
|
50
|
|
|
|
? *MARK : sv_mortalcopy(*MARK); |
2509
|
28363687
|
|
|
|
|
TAINT_NOT; /* Each item is independent */ |
2510
|
|
|
|
|
|
} |
2511
|
|
|
|
|
|
} |
2512
|
242693170
|
|
|
|
|
PL_stack_sp = newsp; |
2513
|
|
|
|
|
|
} |
2514
|
|
|
|
|
|
|
2515
|
242693330
|
|
|
|
|
LEAVE; |
2516
|
|
|
|
|
|
/* Stack values are safe: */ |
2517
|
242693330
|
100
|
|
|
|
if (popsub2) { |
2518
|
242683636
|
|
|
|
|
cxstack_ix--; |
2519
|
364010766
|
100
|
|
|
|
POPSUB(cx,sv); /* release CV and @_ ... */ |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2520
|
|
|
|
|
|
} |
2521
|
|
|
|
|
|
else |
2522
|
|
|
|
|
|
sv = NULL; |
2523
|
242693330
|
|
|
|
|
PL_curpm = newpm; /* ... and pop $1 et al */ |
2524
|
|
|
|
|
|
|
2525
|
242693330
|
|
|
|
|
LEAVESUB(sv); |
2526
|
242693330
|
100
|
|
|
|
if (clear_errsv) { |
2527
|
121390462
|
50
|
|
|
|
CLEAR_ERRSV(); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2528
|
|
|
|
|
|
} |
2529
|
|
|
|
|
|
return retop; |
2530
|
|
|
|
|
|
} |
2531
|
|
|
|
|
|
|
2532
|
|
|
|
|
|
/* This duplicates parts of pp_leavesub, so that it can share code with |
2533
|
|
|
|
|
|
* pp_return */ |
2534
|
1434
|
|
|
|
|
PP(pp_leavesublv) |
2535
|
|
|
|
|
|
{ |
2536
|
1434
|
|
|
|
|
dVAR; dSP; |
2537
|
|
|
|
|
|
SV **newsp; |
2538
|
|
|
|
|
|
PMOP *newpm; |
2539
|
|
|
|
|
|
I32 gimme; |
2540
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2541
|
|
|
|
|
|
SV *sv; |
2542
|
|
|
|
|
|
|
2543
|
1434
|
50
|
|
|
|
if (CxMULTICALL(&cxstack[cxstack_ix])) |
2544
|
|
|
|
|
|
return 0; |
2545
|
|
|
|
|
|
|
2546
|
1434
|
|
|
|
|
POPBLOCK(cx,newpm); |
2547
|
1434
|
|
|
|
|
cxstack_ix++; /* temporarily protect top context */ |
2548
|
|
|
|
|
|
|
2549
|
1434
|
|
|
|
|
TAINT_NOT; |
2550
|
|
|
|
|
|
|
2551
|
1434
|
|
|
|
|
S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm); |
2552
|
|
|
|
|
|
|
2553
|
1414
|
|
|
|
|
LEAVE; |
2554
|
2121
|
100
|
|
|
|
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2555
|
1414
|
|
|
|
|
cxstack_ix--; |
2556
|
1414
|
|
|
|
|
PL_curpm = newpm; /* ... and pop $1 et al */ |
2557
|
|
|
|
|
|
|
2558
|
1414
|
|
|
|
|
LEAVESUB(sv); |
2559
|
1414
|
|
|
|
|
return cx->blk_sub.retop; |
2560
|
|
|
|
|
|
} |
2561
|
|
|
|
|
|
|
2562
|
|
|
|
|
|
static I32 |
2563
|
11685427
|
|
|
|
|
S_unwind_loop(pTHX_ const char * const opname) |
2564
|
|
|
|
|
|
{ |
2565
|
|
|
|
|
|
dVAR; |
2566
|
|
|
|
|
|
I32 cxix; |
2567
|
11685427
|
100
|
|
|
|
if (PL_op->op_flags & OPf_SPECIAL) { |
2568
|
11356549
|
|
|
|
|
cxix = dopoptoloop(cxstack_ix); |
2569
|
11356549
|
100
|
|
|
|
if (cxix < 0) |
2570
|
|
|
|
|
|
/* diag_listed_as: Can't "last" outside a loop block */ |
2571
|
22
|
|
|
|
|
Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); |
2572
|
|
|
|
|
|
} |
2573
|
|
|
|
|
|
else { |
2574
|
328878
|
|
|
|
|
dSP; |
2575
|
|
|
|
|
|
STRLEN label_len; |
2576
|
|
|
|
|
|
const char * const label = |
2577
|
328878
|
|
|
|
|
PL_op->op_flags & OPf_STACKED |
2578
|
12
|
|
|
|
|
? SvPV(TOPs,label_len) |
2579
|
328884
|
100
|
|
|
|
: (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); |
|
|
50
|
|
|
|
|
2580
|
|
|
|
|
|
const U32 label_flags = |
2581
|
328878
|
|
|
|
|
PL_op->op_flags & OPf_STACKED |
2582
|
9
|
|
|
|
|
? SvUTF8(POPs) |
2583
|
493317
|
100
|
|
|
|
: (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; |
|
|
100
|
|
|
|
|
2584
|
328878
|
|
|
|
|
PUTBACK; |
2585
|
328878
|
|
|
|
|
cxix = dopoptolabel(label, label_len, label_flags); |
2586
|
328878
|
100
|
|
|
|
if (cxix < 0) |
2587
|
|
|
|
|
|
/* diag_listed_as: Label not found for "last %s" */ |
2588
|
15
|
50
|
|
|
|
Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", |
2589
|
|
|
|
|
|
opname, |
2590
|
10
|
0
|
|
|
|
SVfARG(PL_op->op_flags & OPf_STACKED |
2591
|
|
|
|
|
|
&& !SvGMAGICAL(TOPp1s) |
2592
|
|
|
|
|
|
? TOPp1s |
2593
|
|
|
|
|
|
: newSVpvn_flags(label, |
2594
|
|
|
|
|
|
label_len, |
2595
|
|
|
|
|
|
label_flags | SVs_TEMP))); |
2596
|
|
|
|
|
|
} |
2597
|
11685395
|
100
|
|
|
|
if (cxix < cxstack_ix) |
2598
|
7257004
|
|
|
|
|
dounwind(cxix); |
2599
|
11685395
|
|
|
|
|
return cxix; |
2600
|
|
|
|
|
|
} |
2601
|
|
|
|
|
|
|
2602
|
2062595
|
|
|
|
|
PP(pp_last) |
2603
|
|
|
|
|
|
{ |
2604
|
|
|
|
|
|
dVAR; |
2605
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2606
|
|
|
|
|
|
I32 pop2 = 0; |
2607
|
|
|
|
|
|
I32 gimme; |
2608
|
|
|
|
|
|
I32 optype; |
2609
|
|
|
|
|
|
OP *nextop = NULL; |
2610
|
|
|
|
|
|
SV **newsp; |
2611
|
|
|
|
|
|
PMOP *newpm; |
2612
|
|
|
|
|
|
SV **mark; |
2613
|
|
|
|
|
|
SV *sv = NULL; |
2614
|
|
|
|
|
|
|
2615
|
2062595
|
|
|
|
|
S_unwind_loop(aTHX_ "last"); |
2616
|
|
|
|
|
|
|
2617
|
2062579
|
|
|
|
|
POPBLOCK(cx,newpm); |
2618
|
2062579
|
|
|
|
|
cxstack_ix++; /* temporarily protect top context */ |
2619
|
|
|
|
|
|
mark = newsp; |
2620
|
2062579
|
|
|
|
|
switch (CxTYPE(cx)) { |
2621
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
2622
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
2623
|
|
|
|
|
|
case CXt_LOOP_FOR: |
2624
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
2625
|
2062579
|
|
|
|
|
pop2 = CxTYPE(cx); |
2626
|
2062579
|
|
|
|
|
newsp = PL_stack_base + cx->blk_loop.resetsp; |
2627
|
2062579
|
|
|
|
|
nextop = cx->blk_loop.my_op->op_lastop->op_next; |
2628
|
2062579
|
|
|
|
|
break; |
2629
|
|
|
|
|
|
case CXt_SUB: |
2630
|
|
|
|
|
|
pop2 = CXt_SUB; |
2631
|
0
|
|
|
|
|
nextop = cx->blk_sub.retop; |
2632
|
0
|
|
|
|
|
break; |
2633
|
|
|
|
|
|
case CXt_EVAL: |
2634
|
0
|
0
|
|
|
|
POPEVAL(cx); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2635
|
0
|
|
|
|
|
nextop = cx->blk_eval.retop; |
2636
|
0
|
|
|
|
|
break; |
2637
|
|
|
|
|
|
case CXt_FORMAT: |
2638
|
0
|
0
|
|
|
|
POPFORMAT(cx); |
|
|
0
|
|
|
|
|
2639
|
0
|
|
|
|
|
nextop = cx->blk_sub.retop; |
2640
|
0
|
|
|
|
|
break; |
2641
|
|
|
|
|
|
default: |
2642
|
0
|
|
|
|
|
DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx)); |
2643
|
|
|
|
|
|
} |
2644
|
|
|
|
|
|
|
2645
|
2062579
|
|
|
|
|
TAINT_NOT; |
2646
|
2062579
|
50
|
|
|
|
PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme, |
2647
|
|
|
|
|
|
pop2 == CXt_SUB ? SVs_TEMP : 0); |
2648
|
|
|
|
|
|
|
2649
|
2062579
|
|
|
|
|
LEAVE; |
2650
|
2062579
|
|
|
|
|
cxstack_ix--; |
2651
|
|
|
|
|
|
/* Stack values are safe: */ |
2652
|
2062579
|
|
|
|
|
switch (pop2) { |
2653
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
2654
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
2655
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
2656
|
|
|
|
|
|
case CXt_LOOP_FOR: |
2657
|
2062579
|
100
|
|
|
|
POPLOOP(cx); /* release loop vars ... */ |
|
|
100
|
|
|
|
|
2658
|
2062579
|
|
|
|
|
LEAVE; |
2659
|
2062579
|
|
|
|
|
break; |
2660
|
|
|
|
|
|
case CXt_SUB: |
2661
|
0
|
0
|
|
|
|
POPSUB(cx,sv); /* release CV and @_ ... */ |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
2662
|
|
|
|
|
|
break; |
2663
|
|
|
|
|
|
} |
2664
|
2062579
|
|
|
|
|
PL_curpm = newpm; /* ... and pop $1 et al */ |
2665
|
|
|
|
|
|
|
2666
|
2062579
|
|
|
|
|
LEAVESUB(sv); |
2667
|
|
|
|
|
|
PERL_UNUSED_VAR(optype); |
2668
|
|
|
|
|
|
PERL_UNUSED_VAR(gimme); |
2669
|
2062579
|
|
|
|
|
return nextop; |
2670
|
|
|
|
|
|
} |
2671
|
|
|
|
|
|
|
2672
|
9356754
|
|
|
|
|
PP(pp_next) |
2673
|
|
|
|
|
|
{ |
2674
|
|
|
|
|
|
dVAR; |
2675
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2676
|
9356754
|
|
|
|
|
const I32 inner = PL_scopestack_ix; |
2677
|
|
|
|
|
|
|
2678
|
9356754
|
|
|
|
|
S_unwind_loop(aTHX_ "next"); |
2679
|
|
|
|
|
|
|
2680
|
|
|
|
|
|
/* clear off anything above the scope we're re-entering, but |
2681
|
|
|
|
|
|
* save the rest until after a possible continue block */ |
2682
|
9356740
|
|
|
|
|
TOPBLOCK(cx); |
2683
|
9356740
|
100
|
|
|
|
if (PL_scopestack_ix < inner) |
2684
|
5320604
|
|
|
|
|
leave_scope(PL_scopestack[PL_scopestack_ix]); |
2685
|
9356740
|
|
|
|
|
PL_curcop = cx->blk_oldcop; |
2686
|
9356740
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
2687
|
9356740
|
|
|
|
|
return (cx)->blk_loop.my_op->op_nextop; |
2688
|
|
|
|
|
|
} |
2689
|
|
|
|
|
|
|
2690
|
266078
|
|
|
|
|
PP(pp_redo) |
2691
|
|
|
|
|
|
{ |
2692
|
|
|
|
|
|
dVAR; |
2693
|
266078
|
|
|
|
|
const I32 cxix = S_unwind_loop(aTHX_ "redo"); |
2694
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2695
|
|
|
|
|
|
I32 oldsave; |
2696
|
266076
|
|
|
|
|
OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; |
2697
|
|
|
|
|
|
|
2698
|
266076
|
100
|
|
|
|
if (redo_op->op_type == OP_ENTER) { |
2699
|
|
|
|
|
|
/* pop one less context to avoid $x being freed in while (my $x..) */ |
2700
|
53056
|
|
|
|
|
cxstack_ix++; |
2701
|
|
|
|
|
|
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); |
2702
|
53056
|
|
|
|
|
redo_op = redo_op->op_next; |
2703
|
|
|
|
|
|
} |
2704
|
|
|
|
|
|
|
2705
|
266076
|
|
|
|
|
TOPBLOCK(cx); |
2706
|
266076
|
|
|
|
|
oldsave = PL_scopestack[PL_scopestack_ix - 1]; |
2707
|
266076
|
100
|
|
|
|
LEAVE_SCOPE(oldsave); |
2708
|
266076
|
100
|
|
|
|
FREETMPS; |
2709
|
266076
|
|
|
|
|
PL_curcop = cx->blk_oldcop; |
2710
|
266076
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
2711
|
266076
|
|
|
|
|
return redo_op; |
2712
|
|
|
|
|
|
} |
2713
|
|
|
|
|
|
|
2714
|
|
|
|
|
|
STATIC OP * |
2715
|
948374
|
|
|
|
|
S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) |
2716
|
|
|
|
|
|
{ |
2717
|
|
|
|
|
|
dVAR; |
2718
|
|
|
|
|
|
OP **ops = opstack; |
2719
|
|
|
|
|
|
static const char* const too_deep = "Target of goto is too deeply nested"; |
2720
|
|
|
|
|
|
|
2721
|
|
|
|
|
|
PERL_ARGS_ASSERT_DOFINDLABEL; |
2722
|
|
|
|
|
|
|
2723
|
948374
|
50
|
|
|
|
if (ops >= oplimit) |
2724
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", too_deep); |
2725
|
1422561
|
100
|
|
|
|
if (o->op_type == OP_LEAVE || |
2726
|
948374
|
|
|
|
|
o->op_type == OP_SCOPE || |
2727
|
903014
|
100
|
|
|
|
o->op_type == OP_LEAVELOOP || |
2728
|
1352521
|
100
|
|
|
|
o->op_type == OP_LEAVESUB || |
2729
|
901014
|
|
|
|
|
o->op_type == OP_LEAVETRY) |
2730
|
|
|
|
|
|
{ |
2731
|
47442
|
|
|
|
|
*ops++ = cUNOPo->op_first; |
2732
|
47442
|
50
|
|
|
|
if (ops >= oplimit) |
2733
|
0
|
|
|
|
|
Perl_croak(aTHX_ "%s", too_deep); |
2734
|
|
|
|
|
|
} |
2735
|
948374
|
|
|
|
|
*ops = 0; |
2736
|
948374
|
100
|
|
|
|
if (o->op_flags & OPf_KIDS) { |
2737
|
|
|
|
|
|
OP *kid; |
2738
|
|
|
|
|
|
/* First try all the kids at this level, since that's likeliest. */ |
2739
|
1506702
|
100
|
|
|
|
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { |
2740
|
1033752
|
100
|
|
|
|
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { |
2741
|
|
|
|
|
|
STRLEN kid_label_len; |
2742
|
|
|
|
|
|
U32 kid_label_flags; |
2743
|
133896
|
|
|
|
|
const char *kid_label = CopLABEL_len_flags(kCOP, |
2744
|
|
|
|
|
|
&kid_label_len, &kid_label_flags); |
2745
|
151016
|
100
|
|
|
|
if (kid_label && ( |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2746
|
8560
|
|
|
|
|
( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? |
2747
|
0
|
|
|
|
|
(flags & SVf_UTF8) |
2748
|
0
|
|
|
|
|
? (bytes_cmp_utf8( |
2749
|
|
|
|
|
|
(const U8*)kid_label, kid_label_len, |
2750
|
|
|
|
|
|
(const U8*)label, len) == 0) |
2751
|
0
|
|
|
|
|
: (bytes_cmp_utf8( |
2752
|
|
|
|
|
|
(const U8*)label, len, |
2753
|
|
|
|
|
|
(const U8*)kid_label, kid_label_len) == 0) |
2754
|
11814
|
50
|
|
|
|
: ( len == kid_label_len && ((kid_label == label) |
2755
|
8047
|
100
|
|
|
|
|| memEQ(kid_label, label, len))))) |
2756
|
|
|
|
|
|
return kid; |
2757
|
|
|
|
|
|
} |
2758
|
|
|
|
|
|
} |
2759
|
1402478
|
100
|
|
|
|
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { |
2760
|
938076
|
100
|
|
|
|
if (kid == PL_lastgotoprobe) |
2761
|
2858
|
|
|
|
|
continue; |
2762
|
935218
|
100
|
|
|
|
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { |
2763
|
84656
|
100
|
|
|
|
if (ops == opstack) |
2764
|
5956
|
|
|
|
|
*ops++ = kid; |
2765
|
78700
|
100
|
|
|
|
else if (ops[-1]->op_type == OP_NEXTSTATE || |
2766
|
|
|
|
|
|
ops[-1]->op_type == OP_DBSTATE) |
2767
|
45826
|
|
|
|
|
ops[-1] = kid; |
2768
|
|
|
|
|
|
else |
2769
|
32874
|
|
|
|
|
*ops++ = kid; |
2770
|
|
|
|
|
|
} |
2771
|
935218
|
100
|
|
|
|
if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) |
2772
|
|
|
|
|
|
return o; |
2773
|
|
|
|
|
|
} |
2774
|
|
|
|
|
|
} |
2775
|
934622
|
|
|
|
|
*ops = 0; |
2776
|
941498
|
|
|
|
|
return 0; |
2777
|
|
|
|
|
|
} |
2778
|
|
|
|
|
|
|
2779
|
122908
|
|
|
|
|
PP(pp_goto) |
2780
|
|
|
|
|
|
{ |
2781
|
122908
|
|
|
|
|
dVAR; dSP; |
2782
|
|
|
|
|
|
OP *retop = NULL; |
2783
|
|
|
|
|
|
I32 ix; |
2784
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2785
|
|
|
|
|
|
#define GOTO_DEPTH 64 |
2786
|
|
|
|
|
|
OP *enterops[GOTO_DEPTH]; |
2787
|
|
|
|
|
|
const char *label = NULL; |
2788
|
122908
|
|
|
|
|
STRLEN label_len = 0; |
2789
|
|
|
|
|
|
U32 label_flags = 0; |
2790
|
122908
|
|
|
|
|
const bool do_dump = (PL_op->op_type == OP_DUMP); |
2791
|
|
|
|
|
|
static const char* const must_have_label = "goto must have label"; |
2792
|
|
|
|
|
|
|
2793
|
180495
|
100
|
|
|
|
if (PL_op->op_flags & OPf_STACKED) { |
|
|
100
|
|
|
|
|
2794
|
117690
|
|
|
|
|
SV * const sv = POPs; |
2795
|
57589
|
|
|
|
|
SvGETMAGIC(sv); |
2796
|
|
|
|
|
|
|
2797
|
|
|
|
|
|
/* This egregious kludge implements goto &subroutine */ |
2798
|
117690
|
100
|
|
|
|
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { |
|
|
50
|
|
|
|
|
2799
|
|
|
|
|
|
I32 cxix; |
2800
|
|
|
|
|
|
PERL_CONTEXT *cx; |
2801
|
117668
|
|
|
|
|
CV *cv = MUTABLE_CV(SvRV(sv)); |
2802
|
117669
|
|
|
|
|
AV *arg = GvAV(PL_defgv); |
2803
|
|
|
|
|
|
I32 oldsave; |
2804
|
|
|
|
|
|
|
2805
|
|
|
|
|
|
retry: |
2806
|
117670
|
100
|
|
|
|
if (!CvROOT(cv) && !CvXSUB(cv)) { |
|
|
50
|
|
|
|
|
2807
|
|
|
|
|
|
const GV * const gv = CvGV(cv); |
2808
|
6
|
50
|
|
|
|
if (gv) { |
2809
|
|
|
|
|
|
GV *autogv; |
2810
|
|
|
|
|
|
SV *tmpstr; |
2811
|
|
|
|
|
|
/* autoloaded stub? */ |
2812
|
6
|
50
|
|
|
|
if (cv != GvCV(gv) && (cv = GvCV(gv))) |
|
|
0
|
|
|
|
|
2813
|
|
|
|
|
|
goto retry; |
2814
|
6
|
100
|
|
|
|
autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), |
2815
|
|
|
|
|
|
GvNAMELEN(gv), |
2816
|
|
|
|
|
|
GvNAMEUTF8(gv) ? SVf_UTF8 : 0); |
2817
|
6
|
100
|
|
|
|
if (autogv && (cv = GvCV(autogv))) |
|
|
50
|
|
|
|
|
2818
|
|
|
|
|
|
goto retry; |
2819
|
4
|
|
|
|
|
tmpstr = sv_newmortal(); |
2820
|
4
|
|
|
|
|
gv_efullname3(tmpstr, gv, NULL); |
2821
|
4
|
|
|
|
|
DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); |
2822
|
|
|
|
|
|
} |
2823
|
0
|
|
|
|
|
DIE(aTHX_ "Goto undefined subroutine"); |
2824
|
|
|
|
|
|
} |
2825
|
|
|
|
|
|
|
2826
|
|
|
|
|
|
/* First do some returnish stuff. */ |
2827
|
117664
|
50
|
|
|
|
SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ |
2828
|
117664
|
100
|
|
|
|
FREETMPS; |
2829
|
117664
|
|
|
|
|
cxix = dopoptosub(cxstack_ix); |
2830
|
117664
|
100
|
|
|
|
if (cxix < cxstack_ix) { |
2831
|
572
|
100
|
|
|
|
if (cxix < 0) { |
2832
|
10
|
|
|
|
|
SvREFCNT_dec(cv); |
2833
|
10
|
|
|
|
|
DIE(aTHX_ "Can't goto subroutine outside a subroutine"); |
2834
|
|
|
|
|
|
} |
2835
|
562
|
|
|
|
|
dounwind(cxix); |
2836
|
|
|
|
|
|
} |
2837
|
117654
|
|
|
|
|
TOPBLOCK(cx); |
2838
|
117654
|
|
|
|
|
SPAGAIN; |
2839
|
|
|
|
|
|
/* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ |
2840
|
117654
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_EVAL) { |
2841
|
8
|
|
|
|
|
SvREFCNT_dec(cv); |
2842
|
8
|
100
|
|
|
|
if (CxREALEVAL(cx)) |
2843
|
|
|
|
|
|
/* diag_listed_as: Can't goto subroutine from an eval-%s */ |
2844
|
6
|
|
|
|
|
DIE(aTHX_ "Can't goto subroutine from an eval-string"); |
2845
|
|
|
|
|
|
else |
2846
|
|
|
|
|
|
/* diag_listed_as: Can't goto subroutine from an eval-%s */ |
2847
|
2
|
|
|
|
|
DIE(aTHX_ "Can't goto subroutine from an eval-block"); |
2848
|
|
|
|
|
|
} |
2849
|
117646
|
100
|
|
|
|
else if (CxMULTICALL(cx)) |
2850
|
|
|
|
|
|
{ |
2851
|
6
|
|
|
|
|
SvREFCNT_dec(cv); |
2852
|
6
|
|
|
|
|
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); |
2853
|
|
|
|
|
|
} |
2854
|
117640
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { |
2855
|
117562
|
|
|
|
|
AV* av = cx->blk_sub.argarray; |
2856
|
|
|
|
|
|
|
2857
|
|
|
|
|
|
/* abandon the original @_ if it got reified or if it is |
2858
|
|
|
|
|
|
the same as the current @_ */ |
2859
|
117562
|
100
|
|
|
|
if (AvREAL(av) || av == arg) { |
2860
|
117558
|
|
|
|
|
SvREFCNT_dec(av); |
2861
|
117558
|
|
|
|
|
av = newAV(); |
2862
|
117558
|
|
|
|
|
AvREIFY_only(av); |
2863
|
117558
|
|
|
|
|
PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); |
2864
|
|
|
|
|
|
} |
2865
|
4
|
|
|
|
|
else CLEAR_ARGARRAY(av); |
2866
|
|
|
|
|
|
} |
2867
|
|
|
|
|
|
/* We donate this refcount later to the callee’s pad. */ |
2868
|
117640
|
50
|
|
|
|
SvREFCNT_inc_simple_void(arg); |
2869
|
175202
|
50
|
|
|
|
if (CxTYPE(cx) == CXt_SUB && |
|
|
100
|
|
|
|
|
2870
|
235280
|
|
|
|
|
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) |
2871
|
117638
|
|
|
|
|
SvREFCNT_dec(cx->blk_sub.cv); |
2872
|
117640
|
|
|
|
|
oldsave = PL_scopestack[PL_scopestack_ix - 1]; |
2873
|
117640
|
50
|
|
|
|
LEAVE_SCOPE(oldsave); |
2874
|
|
|
|
|
|
|
2875
|
|
|
|
|
|
/* A destructor called during LEAVE_SCOPE could have undefined |
2876
|
|
|
|
|
|
* our precious cv. See bug #99850. */ |
2877
|
117640
|
100
|
|
|
|
if (!CvROOT(cv) && !CvXSUB(cv)) { |
|
|
50
|
|
|
|
|
2878
|
|
|
|
|
|
const GV * const gv = CvGV(cv); |
2879
|
2
|
|
|
|
|
SvREFCNT_dec(arg); |
2880
|
2
|
50
|
|
|
|
if (gv) { |
2881
|
2
|
|
|
|
|
SV * const tmpstr = sv_newmortal(); |
2882
|
2
|
|
|
|
|
gv_efullname3(tmpstr, gv, NULL); |
2883
|
2
|
|
|
|
|
DIE(aTHX_ "Goto undefined subroutine &%"SVf"", |
2884
|
|
|
|
|
|
SVfARG(tmpstr)); |
2885
|
|
|
|
|
|
} |
2886
|
0
|
|
|
|
|
DIE(aTHX_ "Goto undefined subroutine"); |
2887
|
|
|
|
|
|
} |
2888
|
|
|
|
|
|
|
2889
|
|
|
|
|
|
/* Now do some callish stuff. */ |
2890
|
117638
|
|
|
|
|
SAVETMPS; |
2891
|
117638
|
|
|
|
|
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ |
2892
|
117656
|
100
|
|
|
|
if (CvISXSUB(cv)) { |
|
|
50
|
|
|
|
|
2893
|
36
|
|
|
|
|
OP* const retop = cx->blk_sub.retop; |
2894
|
|
|
|
|
|
SV **newsp; |
2895
|
|
|
|
|
|
I32 gimme; |
2896
|
36
|
|
|
|
|
const SSize_t items = AvFILLp(arg) + 1; |
2897
|
|
|
|
|
|
SV** mark; |
2898
|
|
|
|
|
|
|
2899
|
|
|
|
|
|
PERL_UNUSED_VAR(newsp); |
2900
|
|
|
|
|
|
PERL_UNUSED_VAR(gimme); |
2901
|
|
|
|
|
|
|
2902
|
|
|
|
|
|
/* put GvAV(defgv) back onto stack */ |
2903
|
18
|
|
|
|
|
EXTEND(SP, items+1); /* @_ could have been extended. */ |
2904
|
36
|
50
|
|
|
|
Copy(AvARRAY(arg), SP + 1, items, SV*); |
2905
|
|
|
|
|
|
mark = SP; |
2906
|
36
|
|
|
|
|
SP += items; |
2907
|
36
|
100
|
|
|
|
if (AvREAL(arg)) { |
2908
|
|
|
|
|
|
I32 index; |
2909
|
6
|
100
|
|
|
|
for (index=0; index
|
2910
|
4
|
|
|
|
|
SvREFCNT_inc_void(sv_2mortal(SP[-index])); |
2911
|
|
|
|
|
|
} |
2912
|
36
|
|
|
|
|
SvREFCNT_dec(arg); |
2913
|
36
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { |
2914
|
|
|
|
|
|
/* Restore old @_ */ |
2915
|
30
|
|
|
|
|
arg = GvAV(PL_defgv); |
2916
|
30
|
|
|
|
|
GvAV(PL_defgv) = cx->blk_sub.savearray; |
2917
|
30
|
|
|
|
|
SvREFCNT_dec(arg); |
2918
|
|
|
|
|
|
} |
2919
|
|
|
|
|
|
|
2920
|
|
|
|
|
|
/* XS subs don't have a CxSUB, so pop it */ |
2921
|
36
|
|
|
|
|
POPBLOCK(cx, PL_curpm); |
2922
|
|
|
|
|
|
/* Push a mark for the start of arglist */ |
2923
|
36
|
50
|
|
|
|
PUSHMARK(mark); |
2924
|
36
|
|
|
|
|
PUTBACK; |
2925
|
36
|
|
|
|
|
(void)(*CvXSUB(cv))(aTHX_ cv); |
2926
|
28
|
|
|
|
|
LEAVE; |
2927
|
28
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
2928
|
|
|
|
|
|
return retop; |
2929
|
|
|
|
|
|
} |
2930
|
|
|
|
|
|
else { |
2931
|
117602
|
|
|
|
|
PADLIST * const padlist = CvPADLIST(cv); |
2932
|
117602
|
|
|
|
|
cx->blk_sub.cv = cv; |
2933
|
117602
|
|
|
|
|
cx->blk_sub.olddepth = CvDEPTH(cv); |
2934
|
|
|
|
|
|
|
2935
|
117602
|
|
|
|
|
CvDEPTH(cv)++; |
2936
|
117602
|
100
|
|
|
|
if (CvDEPTH(cv) < 2) |
2937
|
116270
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(cv); |
2938
|
|
|
|
|
|
else { |
2939
|
1332
|
100
|
|
|
|
if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) |
|
|
50
|
|
|
|
|
2940
|
0
|
|
|
|
|
sub_crush_depth(cv); |
2941
|
1332
|
|
|
|
|
pad_push(padlist, CvDEPTH(cv)); |
2942
|
|
|
|
|
|
} |
2943
|
117602
|
|
|
|
|
PL_curcop = cx->blk_oldcop; |
2944
|
117602
|
|
|
|
|
SAVECOMPPAD(); |
2945
|
235204
|
|
|
|
|
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); |
2946
|
117602
|
100
|
|
|
|
if (CxHASARGS(cx)) |
2947
|
|
|
|
|
|
{ |
2948
|
117530
|
|
|
|
|
CX_CURPAD_SAVE(cx->blk_sub); |
2949
|
|
|
|
|
|
|
2950
|
|
|
|
|
|
/* cx->blk_sub.argarray has no reference count, so we |
2951
|
|
|
|
|
|
need something to hang on to our argument array so |
2952
|
|
|
|
|
|
that cx->blk_sub.argarray does not end up pointing |
2953
|
|
|
|
|
|
to freed memory as the result of undef *_. So put |
2954
|
|
|
|
|
|
it in the callee’s pad, donating our refer- |
2955
|
|
|
|
|
|
ence count. */ |
2956
|
117530
|
|
|
|
|
SvREFCNT_dec(PAD_SVl(0)); |
2957
|
117530
|
|
|
|
|
PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg); |
2958
|
|
|
|
|
|
|
2959
|
|
|
|
|
|
/* GvAV(PL_defgv) might have been modified on scope |
2960
|
|
|
|
|
|
exit, so restore it. */ |
2961
|
117530
|
100
|
|
|
|
if (arg != GvAV(PL_defgv)) { |
2962
|
2
|
|
|
|
|
AV * const av = GvAV(PL_defgv); |
2963
|
4
|
|
|
|
|
GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg); |
2964
|
2
|
|
|
|
|
SvREFCNT_dec(av); |
2965
|
|
|
|
|
|
} |
2966
|
|
|
|
|
|
} |
2967
|
72
|
|
|
|
|
else SvREFCNT_dec(arg); |
2968
|
117602
|
100
|
|
|
|
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ |
|
|
100
|
|
|
|
|
2969
|
42
|
|
|
|
|
Perl_get_db_sub(aTHX_ NULL, cv); |
2970
|
42
|
50
|
|
|
|
if (PERLDB_GOTO) { |
|
|
50
|
|
|
|
|
2971
|
0
|
|
|
|
|
CV * const gotocv = get_cvs("DB::goto", 0); |
2972
|
0
|
0
|
|
|
|
if (gotocv) { |
2973
|
0
|
0
|
|
|
|
PUSHMARK( PL_stack_sp ); |
2974
|
0
|
|
|
|
|
call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); |
2975
|
0
|
|
|
|
|
PL_stack_sp--; |
2976
|
|
|
|
|
|
} |
2977
|
|
|
|
|
|
} |
2978
|
|
|
|
|
|
} |
2979
|
117602
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
2980
|
117602
|
|
|
|
|
RETURNOP(CvSTART(cv)); |
2981
|
|
|
|
|
|
} |
2982
|
|
|
|
|
|
} |
2983
|
|
|
|
|
|
else { |
2984
|
22
|
50
|
|
|
|
label = SvPV_nomg_const(sv, label_len); |
2985
|
22
|
|
|
|
|
label_flags = SvUTF8(sv); |
2986
|
|
|
|
|
|
} |
2987
|
|
|
|
|
|
} |
2988
|
5218
|
100
|
|
|
|
else if (!(PL_op->op_flags & OPf_SPECIAL)) { |
2989
|
5216
|
|
|
|
|
label = cPVOP->op_pv; |
2990
|
5216
|
100
|
|
|
|
label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; |
2991
|
5216
|
|
|
|
|
label_len = strlen(label); |
2992
|
|
|
|
|
|
} |
2993
|
5240
|
100
|
|
|
|
if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label); |
|
|
100
|
|
|
|
|
2994
|
|
|
|
|
|
|
2995
|
5234
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
2996
|
|
|
|
|
|
|
2997
|
5234
|
50
|
|
|
|
if (label_len) { |
2998
|
|
|
|
|
|
OP *gotoprobe = NULL; |
2999
|
|
|
|
|
|
bool leaving_eval = FALSE; |
3000
|
|
|
|
|
|
bool in_block = FALSE; |
3001
|
|
|
|
|
|
PERL_CONTEXT *last_eval_cx = NULL; |
3002
|
|
|
|
|
|
|
3003
|
|
|
|
|
|
/* find label */ |
3004
|
|
|
|
|
|
|
3005
|
5234
|
|
|
|
|
PL_lastgotoprobe = NULL; |
3006
|
5234
|
|
|
|
|
*enterops = 0; |
3007
|
13170
|
100
|
|
|
|
for (ix = cxstack_ix; ix >= 0; ix--) { |
3008
|
13154
|
|
|
|
|
cx = &cxstack[ix]; |
3009
|
13154
|
|
|
|
|
switch (CxTYPE(cx)) { |
3010
|
|
|
|
|
|
case CXt_EVAL: |
3011
|
|
|
|
|
|
leaving_eval = TRUE; |
3012
|
90
|
100
|
|
|
|
if (!CxTRYBLOCK(cx)) { |
3013
|
|
|
|
|
|
gotoprobe = (last_eval_cx ? |
3014
|
74
|
100
|
|
|
|
last_eval_cx->blk_eval.old_eval_root : |
3015
|
|
|
|
|
|
PL_eval_root); |
3016
|
|
|
|
|
|
last_eval_cx = cx; |
3017
|
74
|
|
|
|
|
break; |
3018
|
|
|
|
|
|
} |
3019
|
|
|
|
|
|
/* else fall through */ |
3020
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
3021
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
3022
|
|
|
|
|
|
case CXt_LOOP_FOR: |
3023
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
3024
|
|
|
|
|
|
case CXt_GIVEN: |
3025
|
|
|
|
|
|
case CXt_WHEN: |
3026
|
908
|
|
|
|
|
gotoprobe = cx->blk_oldcop->op_sibling; |
3027
|
908
|
|
|
|
|
break; |
3028
|
|
|
|
|
|
case CXt_SUBST: |
3029
|
0
|
|
|
|
|
continue; |
3030
|
|
|
|
|
|
case CXt_BLOCK: |
3031
|
10158
|
100
|
|
|
|
if (ix) { |
3032
|
10092
|
|
|
|
|
gotoprobe = cx->blk_oldcop->op_sibling; |
3033
|
|
|
|
|
|
in_block = TRUE; |
3034
|
|
|
|
|
|
} else |
3035
|
66
|
|
|
|
|
gotoprobe = PL_main_root; |
3036
|
|
|
|
|
|
break; |
3037
|
|
|
|
|
|
case CXt_SUB: |
3038
|
3018
|
50
|
|
|
|
if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { |
|
|
100
|
|
|
|
|
3039
|
2000
|
|
|
|
|
gotoprobe = CvROOT(cx->blk_sub.cv); |
3040
|
2000
|
|
|
|
|
break; |
3041
|
|
|
|
|
|
} |
3042
|
|
|
|
|
|
/* FALL THROUGH */ |
3043
|
|
|
|
|
|
case CXt_FORMAT: |
3044
|
|
|
|
|
|
case CXt_NULL: |
3045
|
14
|
|
|
|
|
DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); |
3046
|
|
|
|
|
|
default: |
3047
|
0
|
0
|
|
|
|
if (ix) |
3048
|
0
|
|
|
|
|
DIE(aTHX_ "panic: goto, type=%u, ix=%ld", |
3049
|
0
|
|
|
|
|
CxTYPE(cx), (long) ix); |
3050
|
0
|
|
|
|
|
gotoprobe = PL_main_root; |
3051
|
0
|
|
|
|
|
break; |
3052
|
|
|
|
|
|
} |
3053
|
13140
|
50
|
|
|
|
if (gotoprobe) { |
3054
|
13140
|
|
|
|
|
retop = dofindlabel(gotoprobe, label, label_len, label_flags, |
3055
|
|
|
|
|
|
enterops, enterops + GOTO_DEPTH); |
3056
|
13140
|
100
|
|
|
|
if (retop) |
3057
|
|
|
|
|
|
break; |
3058
|
10535
|
100
|
|
|
|
if (gotoprobe->op_sibling && |
|
|
100
|
|
|
|
|
3059
|
2805
|
100
|
|
|
|
gotoprobe->op_sibling->op_type == OP_UNSTACK && |
3060
|
218
|
|
|
|
|
gotoprobe->op_sibling->op_sibling) { |
3061
|
16
|
|
|
|
|
retop = dofindlabel(gotoprobe->op_sibling->op_sibling, |
3062
|
|
|
|
|
|
label, label_len, label_flags, enterops, |
3063
|
|
|
|
|
|
enterops + GOTO_DEPTH); |
3064
|
16
|
100
|
|
|
|
if (retop) |
3065
|
|
|
|
|
|
break; |
3066
|
|
|
|
|
|
} |
3067
|
|
|
|
|
|
} |
3068
|
7936
|
|
|
|
|
PL_lastgotoprobe = gotoprobe; |
3069
|
|
|
|
|
|
} |
3070
|
5220
|
100
|
|
|
|
if (!retop) |
3071
|
16
|
|
|
|
|
DIE(aTHX_ "Can't find label %"UTF8f, |
3072
|
|
|
|
|
|
UTF8fARG(label_flags, label_len, label)); |
3073
|
|
|
|
|
|
|
3074
|
|
|
|
|
|
/* if we're leaving an eval, check before we pop any frames |
3075
|
|
|
|
|
|
that we're not going to punt, otherwise the error |
3076
|
|
|
|
|
|
won't be caught */ |
3077
|
|
|
|
|
|
|
3078
|
5204
|
100
|
|
|
|
if (leaving_eval && *enterops && enterops[1]) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3079
|
|
|
|
|
|
I32 i; |
3080
|
12
|
100
|
|
|
|
for (i = 1; enterops[i]; i++) |
3081
|
12
|
100
|
|
|
|
if (enterops[i]->op_type == OP_ENTERITER) |
3082
|
4
|
|
|
|
|
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); |
3083
|
|
|
|
|
|
} |
3084
|
|
|
|
|
|
|
3085
|
5200
|
100
|
|
|
|
if (*enterops && enterops[1]) { |
|
|
100
|
|
|
|
|
3086
|
28
|
100
|
|
|
|
I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; |
|
|
100
|
|
|
|
|
3087
|
28
|
100
|
|
|
|
if (enterops[i]) |
3088
|
14
|
|
|
|
|
deprecate("\"goto\" to jump into a construct"); |
3089
|
|
|
|
|
|
} |
3090
|
|
|
|
|
|
|
3091
|
|
|
|
|
|
/* pop unwanted frames */ |
3092
|
|
|
|
|
|
|
3093
|
5200
|
100
|
|
|
|
if (ix < cxstack_ix) { |
3094
|
|
|
|
|
|
I32 oldsave; |
3095
|
|
|
|
|
|
|
3096
|
5042
|
50
|
|
|
|
if (ix < 0) |
3097
|
|
|
|
|
|
ix = 0; |
3098
|
5042
|
|
|
|
|
dounwind(ix); |
3099
|
5042
|
|
|
|
|
TOPBLOCK(cx); |
3100
|
5042
|
|
|
|
|
oldsave = PL_scopestack[PL_scopestack_ix]; |
3101
|
5042
|
100
|
|
|
|
LEAVE_SCOPE(oldsave); |
3102
|
|
|
|
|
|
} |
3103
|
|
|
|
|
|
|
3104
|
|
|
|
|
|
/* push wanted frames */ |
3105
|
|
|
|
|
|
|
3106
|
5200
|
100
|
|
|
|
if (*enterops && enterops[1]) { |
|
|
100
|
|
|
|
|
3107
|
28
|
|
|
|
|
OP * const oldop = PL_op; |
3108
|
28
|
100
|
|
|
|
ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; |
|
|
100
|
|
|
|
|
3109
|
58
|
100
|
|
|
|
for (; enterops[ix]; ix++) { |
3110
|
30
|
|
|
|
|
PL_op = enterops[ix]; |
3111
|
|
|
|
|
|
/* Eventually we may want to stack the needed arguments |
3112
|
|
|
|
|
|
* for each op. For now, we punt on the hard ones. */ |
3113
|
30
|
50
|
|
|
|
if (PL_op->op_type == OP_ENTERITER) |
3114
|
0
|
|
|
|
|
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); |
3115
|
30
|
|
|
|
|
PL_op->op_ppaddr(aTHX); |
3116
|
|
|
|
|
|
} |
3117
|
28
|
|
|
|
|
PL_op = oldop; |
3118
|
|
|
|
|
|
} |
3119
|
|
|
|
|
|
} |
3120
|
|
|
|
|
|
|
3121
|
5200
|
50
|
|
|
|
if (do_dump) { |
3122
|
|
|
|
|
|
#ifdef VMS |
3123
|
|
|
|
|
|
if (!retop) retop = PL_main_start; |
3124
|
|
|
|
|
|
#endif |
3125
|
0
|
|
|
|
|
PL_restartop = retop; |
3126
|
0
|
|
|
|
|
PL_do_undump = TRUE; |
3127
|
|
|
|
|
|
|
3128
|
0
|
|
|
|
|
my_unexec(); |
3129
|
|
|
|
|
|
|
3130
|
0
|
|
|
|
|
PL_restartop = 0; /* hmm, must be GNU unexec().. */ |
3131
|
0
|
|
|
|
|
PL_do_undump = FALSE; |
3132
|
|
|
|
|
|
} |
3133
|
|
|
|
|
|
|
3134
|
5200
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
3135
|
65273
|
|
|
|
|
RETURNOP(retop); |
3136
|
|
|
|
|
|
} |
3137
|
|
|
|
|
|
|
3138
|
1268
|
|
|
|
|
PP(pp_exit) |
3139
|
|
|
|
|
|
{ |
3140
|
|
|
|
|
|
dVAR; |
3141
|
1268
|
|
|
|
|
dSP; |
3142
|
|
|
|
|
|
I32 anum; |
3143
|
|
|
|
|
|
|
3144
|
1268
|
100
|
|
|
|
if (MAXARG < 1) |
3145
|
|
|
|
|
|
anum = 0; |
3146
|
1076
|
100
|
|
|
|
else if (!TOPs) { |
3147
|
|
|
|
|
|
anum = 0; (void)POPs; |
3148
|
|
|
|
|
|
} |
3149
|
|
|
|
|
|
else { |
3150
|
1074
|
100
|
|
|
|
anum = SvIVx(POPs); |
3151
|
|
|
|
|
|
#ifdef VMS |
3152
|
|
|
|
|
|
if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) |
3153
|
|
|
|
|
|
anum = 0; |
3154
|
|
|
|
|
|
VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); |
3155
|
|
|
|
|
|
#endif |
3156
|
|
|
|
|
|
} |
3157
|
1268
|
|
|
|
|
PL_exit_flags |= PERL_EXIT_EXPECTED; |
3158
|
|
|
|
|
|
#ifdef PERL_MAD |
3159
|
|
|
|
|
|
/* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */ |
3160
|
|
|
|
|
|
if (anum || !(PL_minus_c && PL_madskills)) |
3161
|
|
|
|
|
|
my_exit(anum); |
3162
|
|
|
|
|
|
#else |
3163
|
1268
|
|
|
|
|
my_exit(anum); |
3164
|
|
|
|
|
|
#endif |
3165
|
|
|
|
|
|
PUSHs(&PL_sv_undef); |
3166
|
|
|
|
|
|
RETURN; |
3167
|
|
|
|
|
|
} |
3168
|
|
|
|
|
|
|
3169
|
|
|
|
|
|
/* Eval. */ |
3170
|
|
|
|
|
|
|
3171
|
|
|
|
|
|
STATIC void |
3172
|
|
|
|
|
|
S_save_lines(pTHX_ AV *array, SV *sv) |
3173
|
|
|
|
|
|
{ |
3174
|
940
|
|
|
|
|
const char *s = SvPVX_const(sv); |
3175
|
940
|
|
|
|
|
const char * const send = SvPVX_const(sv) + SvCUR(sv); |
3176
|
|
|
|
|
|
I32 line = 1; |
3177
|
|
|
|
|
|
|
3178
|
|
|
|
|
|
PERL_ARGS_ASSERT_SAVE_LINES; |
3179
|
|
|
|
|
|
|
3180
|
3326
|
100
|
|
|
|
while (s && s < send) { |
3181
|
|
|
|
|
|
const char *t; |
3182
|
2386
|
|
|
|
|
SV * const tmpstr = newSV_type(SVt_PVMG); |
3183
|
|
|
|
|
|
|
3184
|
2386
|
|
|
|
|
t = (const char *)memchr(s, '\n', send - s); |
3185
|
2386
|
100
|
|
|
|
if (t) |
3186
|
1446
|
|
|
|
|
t++; |
3187
|
|
|
|
|
|
else |
3188
|
|
|
|
|
|
t = send; |
3189
|
|
|
|
|
|
|
3190
|
2386
|
|
|
|
|
sv_setpvn(tmpstr, s, t - s); |
3191
|
2386
|
|
|
|
|
av_store(array, line++, tmpstr); |
3192
|
|
|
|
|
|
s = t; |
3193
|
|
|
|
|
|
} |
3194
|
|
|
|
|
|
} |
3195
|
|
|
|
|
|
|
3196
|
|
|
|
|
|
/* |
3197
|
|
|
|
|
|
=for apidoc docatch |
3198
|
|
|
|
|
|
|
3199
|
|
|
|
|
|
Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. |
3200
|
|
|
|
|
|
|
3201
|
|
|
|
|
|
0 is used as continue inside eval, |
3202
|
|
|
|
|
|
|
3203
|
|
|
|
|
|
3 is used for a die caught by an inner eval - continue inner loop |
3204
|
|
|
|
|
|
|
3205
|
|
|
|
|
|
See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must |
3206
|
|
|
|
|
|
establish a local jmpenv to handle exception traps. |
3207
|
|
|
|
|
|
|
3208
|
|
|
|
|
|
=cut |
3209
|
|
|
|
|
|
*/ |
3210
|
|
|
|
|
|
STATIC OP * |
3211
|
26033
|
|
|
|
|
S_docatch(pTHX_ OP *o) |
3212
|
|
|
|
|
|
{ |
3213
|
|
|
|
|
|
dVAR; |
3214
|
|
|
|
|
|
int ret; |
3215
|
26033
|
|
|
|
|
OP * const oldop = PL_op; |
3216
|
|
|
|
|
|
dJMPENV; |
3217
|
|
|
|
|
|
|
3218
|
|
|
|
|
|
#ifdef DEBUGGING |
3219
|
|
|
|
|
|
assert(CATCH_GET == TRUE); |
3220
|
|
|
|
|
|
#endif |
3221
|
26033
|
|
|
|
|
PL_op = o; |
3222
|
|
|
|
|
|
|
3223
|
26033
|
|
|
|
|
JMPENV_PUSH(ret); |
3224
|
27447
|
|
|
|
|
switch (ret) { |
3225
|
|
|
|
|
|
case 0: |
3226
|
|
|
|
|
|
assert(cxstack_ix >= 0); |
3227
|
|
|
|
|
|
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); |
3228
|
26033
|
|
|
|
|
cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; |
3229
|
|
|
|
|
|
redo_body: |
3230
|
26899
|
|
|
|
|
CALLRUNOPS(aTHX); |
3231
|
|
|
|
|
|
break; |
3232
|
|
|
|
|
|
case 3: |
3233
|
|
|
|
|
|
/* die caught by an inner eval - continue inner loop */ |
3234
|
1406
|
100
|
|
|
|
if (PL_restartop && PL_restartjmpenv == PL_top_env) { |
|
|
100
|
|
|
|
|
3235
|
866
|
|
|
|
|
PL_restartjmpenv = NULL; |
3236
|
866
|
|
|
|
|
PL_op = PL_restartop; |
3237
|
866
|
|
|
|
|
PL_restartop = 0; |
3238
|
866
|
|
|
|
|
goto redo_body; |
3239
|
|
|
|
|
|
} |
3240
|
|
|
|
|
|
/* FALL THROUGH */ |
3241
|
|
|
|
|
|
default: |
3242
|
548
|
|
|
|
|
JMPENV_POP; |
3243
|
548
|
|
|
|
|
PL_op = oldop; |
3244
|
548
|
50
|
|
|
|
JMPENV_JUMP(ret); |
|
|
0
|
|
|
|
|
3245
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
3246
|
|
|
|
|
|
} |
3247
|
25485
|
|
|
|
|
JMPENV_POP; |
3248
|
25485
|
|
|
|
|
PL_op = oldop; |
3249
|
25485
|
|
|
|
|
return NULL; |
3250
|
|
|
|
|
|
} |
3251
|
|
|
|
|
|
|
3252
|
|
|
|
|
|
|
3253
|
|
|
|
|
|
/* |
3254
|
|
|
|
|
|
=for apidoc find_runcv |
3255
|
|
|
|
|
|
|
3256
|
|
|
|
|
|
Locate the CV corresponding to the currently executing sub or eval. |
3257
|
|
|
|
|
|
If db_seqp is non_null, skip CVs that are in the DB package and populate |
3258
|
|
|
|
|
|
*db_seqp with the cop sequence number at the point that the DB:: code was |
3259
|
|
|
|
|
|
entered. (allows debuggers to eval in the scope of the breakpoint rather |
3260
|
|
|
|
|
|
than in the scope of the debugger itself). |
3261
|
|
|
|
|
|
|
3262
|
|
|
|
|
|
=cut |
3263
|
|
|
|
|
|
*/ |
3264
|
|
|
|
|
|
|
3265
|
|
|
|
|
|
CV* |
3266
|
6944666
|
|
|
|
|
Perl_find_runcv(pTHX_ U32 *db_seqp) |
3267
|
|
|
|
|
|
{ |
3268
|
6944666
|
|
|
|
|
return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp); |
3269
|
|
|
|
|
|
} |
3270
|
|
|
|
|
|
|
3271
|
|
|
|
|
|
/* If this becomes part of the API, it might need a better name. */ |
3272
|
|
|
|
|
|
CV * |
3273
|
6944816
|
|
|
|
|
Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) |
3274
|
|
|
|
|
|
{ |
3275
|
|
|
|
|
|
dVAR; |
3276
|
|
|
|
|
|
PERL_SI *si; |
3277
|
|
|
|
|
|
int level = 0; |
3278
|
|
|
|
|
|
|
3279
|
6944816
|
100
|
|
|
|
if (db_seqp) |
3280
|
3759872
|
|
|
|
|
*db_seqp = |
3281
|
|
|
|
|
|
PL_curcop == &PL_compiling |
3282
|
|
|
|
|
|
? PL_cop_seqmax |
3283
|
3759872
|
100
|
|
|
|
: PL_curcop->cop_seq; |
3284
|
|
|
|
|
|
|
3285
|
7229768
|
100
|
|
|
|
for (si = PL_curstackinfo; si; si = si->si_prev) { |
3286
|
|
|
|
|
|
I32 ix; |
3287
|
9579105
|
100
|
|
|
|
for (ix = si->si_cxix; ix >= 0; ix--) { |
3288
|
9294153
|
|
|
|
|
const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); |
3289
|
|
|
|
|
|
CV *cv = NULL; |
3290
|
9294153
|
100
|
|
|
|
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
3291
|
6395848
|
|
|
|
|
cv = cx->blk_sub.cv; |
3292
|
|
|
|
|
|
/* skip DB:: code */ |
3293
|
6395848
|
100
|
|
|
|
if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3294
|
894
|
|
|
|
|
*db_seqp = cx->blk_oldcop->cop_seq; |
3295
|
894
|
|
|
|
|
continue; |
3296
|
|
|
|
|
|
} |
3297
|
6394954
|
100
|
|
|
|
if (cx->cx_type & CXp_SUB_RE) |
3298
|
8
|
|
|
|
|
continue; |
3299
|
|
|
|
|
|
} |
3300
|
2898305
|
100
|
|
|
|
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) |
|
|
100
|
|
|
|
|
3301
|
265190
|
|
|
|
|
cv = cx->blk_eval.cv; |
3302
|
9293251
|
100
|
|
|
|
if (cv) { |
3303
|
6660136
|
|
|
|
|
switch (cond) { |
3304
|
|
|
|
|
|
case FIND_RUNCV_padid_eq: |
3305
|
20
|
50
|
|
|
|
if (!CvPADLIST(cv) |
3306
|
20
|
100
|
|
|
|
|| PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg)) |
3307
|
12
|
|
|
|
|
continue; |
3308
|
|
|
|
|
|
return cv; |
3309
|
|
|
|
|
|
case FIND_RUNCV_level_eq: |
3310
|
250
|
100
|
|
|
|
if (level++ != arg) continue; |
3311
|
|
|
|
|
|
/* GERONIMO! */ |
3312
|
|
|
|
|
|
default: |
3313
|
|
|
|
|
|
return cv; |
3314
|
|
|
|
|
|
} |
3315
|
|
|
|
|
|
} |
3316
|
|
|
|
|
|
} |
3317
|
|
|
|
|
|
} |
3318
|
3631377
|
100
|
|
|
|
return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; |
3319
|
|
|
|
|
|
} |
3320
|
|
|
|
|
|
|
3321
|
|
|
|
|
|
|
3322
|
|
|
|
|
|
/* Run yyparse() in a setjmp wrapper. Returns: |
3323
|
|
|
|
|
|
* 0: yyparse() successful |
3324
|
|
|
|
|
|
* 1: yyparse() failed |
3325
|
|
|
|
|
|
* 3: yyparse() died |
3326
|
|
|
|
|
|
*/ |
3327
|
|
|
|
|
|
STATIC int |
3328
|
8662
|
|
|
|
|
S_try_yyparse(pTHX_ int gramtype) |
3329
|
|
|
|
|
|
{ |
3330
|
|
|
|
|
|
int ret; |
3331
|
|
|
|
|
|
dJMPENV; |
3332
|
|
|
|
|
|
|
3333
|
|
|
|
|
|
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); |
3334
|
8662
|
|
|
|
|
JMPENV_PUSH(ret); |
3335
|
8676
|
|
|
|
|
switch (ret) { |
3336
|
|
|
|
|
|
case 0: |
3337
|
8662
|
|
|
|
|
ret = yyparse(gramtype) ? 1 : 0; |
3338
|
8648
|
|
|
|
|
break; |
3339
|
|
|
|
|
|
case 3: |
3340
|
|
|
|
|
|
break; |
3341
|
|
|
|
|
|
default: |
3342
|
0
|
|
|
|
|
JMPENV_POP; |
3343
|
0
|
0
|
|
|
|
JMPENV_JUMP(ret); |
|
|
0
|
|
|
|
|
3344
|
|
|
|
|
|
assert(0); /* NOTREACHED */ |
3345
|
|
|
|
|
|
} |
3346
|
8662
|
|
|
|
|
JMPENV_POP; |
3347
|
8662
|
|
|
|
|
return ret; |
3348
|
|
|
|
|
|
} |
3349
|
|
|
|
|
|
|
3350
|
|
|
|
|
|
|
3351
|
|
|
|
|
|
/* Compile a require/do or an eval ''. |
3352
|
|
|
|
|
|
* |
3353
|
|
|
|
|
|
* outside is the lexically enclosing CV (if any) that invoked us. |
3354
|
|
|
|
|
|
* seq is the current COP scope value. |
3355
|
|
|
|
|
|
* hh is the saved hints hash, if any. |
3356
|
|
|
|
|
|
* |
3357
|
|
|
|
|
|
* Returns a bool indicating whether the compile was successful; if so, |
3358
|
|
|
|
|
|
* PL_eval_start contains the first op of the compiled code; otherwise, |
3359
|
|
|
|
|
|
* pushes undef. |
3360
|
|
|
|
|
|
* |
3361
|
|
|
|
|
|
* This function is called from two places: pp_require and pp_entereval. |
3362
|
|
|
|
|
|
* These can be distinguished by whether PL_op is entereval. |
3363
|
|
|
|
|
|
*/ |
3364
|
|
|
|
|
|
|
3365
|
|
|
|
|
|
STATIC bool |
3366
|
4350983
|
|
|
|
|
S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) |
3367
|
|
|
|
|
|
{ |
3368
|
4350983
|
|
|
|
|
dVAR; dSP; |
3369
|
4350983
|
|
|
|
|
OP * const saveop = PL_op; |
3370
|
4350983
|
|
|
|
|
bool clear_hints = saveop->op_type != OP_ENTEREVAL; |
3371
|
4350983
|
|
|
|
|
COP * const oldcurcop = PL_curcop; |
3372
|
4350983
|
|
|
|
|
bool in_require = (saveop->op_type == OP_REQUIRE); |
3373
|
|
|
|
|
|
int yystatus; |
3374
|
|
|
|
|
|
CV *evalcv; |
3375
|
|
|
|
|
|
|
3376
|
6230788
|
100
|
|
|
|
PL_in_eval = (in_require |
|
|
100
|
|
|
|
|
3377
|
|
|
|
|
|
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) |
3378
|
|
|
|
|
|
: (EVAL_INEVAL | |
3379
|
3781928
|
|
|
|
|
((PL_op->op_private & OPpEVAL_RE_REPARSING) |
3380
|
|
|
|
|
|
? EVAL_RE_REPARSING : 0))); |
3381
|
|
|
|
|
|
|
3382
|
4350983
|
50
|
|
|
|
PUSHMARK(SP); |
3383
|
|
|
|
|
|
|
3384
|
4350983
|
|
|
|
|
evalcv = MUTABLE_CV(newSV_type(SVt_PVCV)); |
3385
|
4350983
|
|
|
|
|
CvEVAL_on(evalcv); |
3386
|
|
|
|
|
|
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); |
3387
|
4350983
|
|
|
|
|
cxstack[cxstack_ix].blk_eval.cv = evalcv; |
3388
|
4350983
|
|
|
|
|
cxstack[cxstack_ix].blk_gimme = gimme; |
3389
|
|
|
|
|
|
|
3390
|
4350983
|
|
|
|
|
CvOUTSIDE_SEQ(evalcv) = seq; |
3391
|
8701966
|
|
|
|
|
CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); |
3392
|
|
|
|
|
|
|
3393
|
|
|
|
|
|
/* set up a scratch pad */ |
3394
|
|
|
|
|
|
|
3395
|
4350983
|
|
|
|
|
CvPADLIST(evalcv) = pad_new(padnew_SAVE); |
3396
|
4350983
|
|
|
|
|
PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ |
3397
|
|
|
|
|
|
|
3398
|
|
|
|
|
|
|
3399
|
|
|
|
|
|
if (!PL_madskills) |
3400
|
4350983
|
|
|
|
|
SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */ |
3401
|
|
|
|
|
|
|
3402
|
|
|
|
|
|
/* make sure we compile in the right package */ |
3403
|
|
|
|
|
|
|
3404
|
4350983
|
100
|
|
|
|
if (CopSTASH_ne(PL_curcop, PL_curstash)) { |
3405
|
2930969
|
|
|
|
|
SAVEGENERICSV(PL_curstash); |
3406
|
2930969
|
|
|
|
|
PL_curstash = (HV *)CopSTASH(PL_curcop); |
3407
|
2930969
|
100
|
|
|
|
if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; |
3408
|
2930967
|
50
|
|
|
|
else SvREFCNT_inc_simple_void(PL_curstash); |
3409
|
|
|
|
|
|
} |
3410
|
|
|
|
|
|
/* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ |
3411
|
4350983
|
|
|
|
|
SAVESPTR(PL_beginav); |
3412
|
4350983
|
|
|
|
|
PL_beginav = newAV(); |
3413
|
4350983
|
|
|
|
|
SAVEFREESV(PL_beginav); |
3414
|
4350983
|
|
|
|
|
SAVESPTR(PL_unitcheckav); |
3415
|
4350983
|
|
|
|
|
PL_unitcheckav = newAV(); |
3416
|
4350983
|
|
|
|
|
SAVEFREESV(PL_unitcheckav); |
3417
|
|
|
|
|
|
|
3418
|
|
|
|
|
|
#ifdef PERL_MAD |
3419
|
|
|
|
|
|
SAVEBOOL(PL_madskills); |
3420
|
|
|
|
|
|
PL_madskills = 0; |
3421
|
|
|
|
|
|
#endif |
3422
|
|
|
|
|
|
|
3423
|
4350983
|
|
|
|
|
ENTER_with_name("evalcomp"); |
3424
|
4350983
|
|
|
|
|
SAVESPTR(PL_compcv); |
3425
|
4350983
|
|
|
|
|
PL_compcv = evalcv; |
3426
|
|
|
|
|
|
|
3427
|
|
|
|
|
|
/* try to compile it */ |
3428
|
|
|
|
|
|
|
3429
|
4350983
|
|
|
|
|
PL_eval_root = NULL; |
3430
|
4350983
|
|
|
|
|
PL_curcop = &PL_compiling; |
3431
|
4350983
|
100
|
|
|
|
if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) |
|
|
100
|
|
|
|
|
3432
|
24
|
|
|
|
|
PL_in_eval |= EVAL_KEEPERR; |
3433
|
|
|
|
|
|
else |
3434
|
4350959
|
100
|
|
|
|
CLEAR_ERRSV(); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3435
|
|
|
|
|
|
|
3436
|
4350983
|
|
|
|
|
SAVEHINTS(); |
3437
|
4350983
|
100
|
|
|
|
if (clear_hints) { |
3438
|
591111
|
|
|
|
|
PL_hints = 0; |
3439
|
591111
|
|
|
|
|
hv_clear(GvHV(PL_hintgv)); |
3440
|
|
|
|
|
|
} |
3441
|
|
|
|
|
|
else { |
3442
|
5628602
|
100
|
|
|
|
PL_hints = saveop->op_private & OPpEVAL_COPHH |
3443
|
3759778
|
|
|
|
|
? oldcurcop->cop_hints : saveop->op_targ; |
3444
|
|
|
|
|
|
|
3445
|
|
|
|
|
|
/* making 'use re eval' not be in scope when compiling the |
3446
|
|
|
|
|
|
* qr/mabye_has_runtime_code_block/ ensures that we don't get |
3447
|
|
|
|
|
|
* infinite recursion when S_has_runtime_code() gives a false |
3448
|
|
|
|
|
|
* positive: the second time round, HINT_RE_EVAL isn't set so we |
3449
|
|
|
|
|
|
* don't bother calling S_has_runtime_code() */ |
3450
|
3759872
|
100
|
|
|
|
if (PL_in_eval & EVAL_RE_REPARSING) |
3451
|
88
|
|
|
|
|
PL_hints &= ~HINT_RE_EVAL; |
3452
|
|
|
|
|
|
|
3453
|
3759872
|
100
|
|
|
|
if (hh) { |
3454
|
|
|
|
|
|
/* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ |
3455
|
304798
|
|
|
|
|
SvREFCNT_dec(GvHV(PL_hintgv)); |
3456
|
304798
|
|
|
|
|
GvHV(PL_hintgv) = hh; |
3457
|
|
|
|
|
|
} |
3458
|
|
|
|
|
|
} |
3459
|
4350983
|
|
|
|
|
SAVECOMPILEWARNINGS(); |
3460
|
4350983
|
100
|
|
|
|
if (clear_hints) { |
3461
|
591111
|
100
|
|
|
|
if (PL_dowarn & G_WARN_ALL_ON) |
3462
|
94
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_ALL ; |
3463
|
591017
|
100
|
|
|
|
else if (PL_dowarn & G_WARN_ALL_OFF) |
3464
|
118
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_NONE ; |
3465
|
|
|
|
|
|
else |
3466
|
590899
|
|
|
|
|
PL_compiling.cop_warnings = pWARN_STD ; |
3467
|
|
|
|
|
|
} |
3468
|
|
|
|
|
|
else { |
3469
|
3759872
|
|
|
|
|
PL_compiling.cop_warnings = |
3470
|
3759872
|
100
|
|
|
|
DUP_WARNINGS(oldcurcop->cop_warnings); |
|
|
100
|
|
|
|
|
3471
|
3759872
|
|
|
|
|
cophh_free(CopHINTHASH_get(&PL_compiling)); |
3472
|
3759872
|
100
|
|
|
|
if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { |
3473
|
|
|
|
|
|
/* The label, if present, is the first entry on the chain. So rather |
3474
|
|
|
|
|
|
than writing a blank label in front of it (which involves an |
3475
|
|
|
|
|
|
allocation), just use the next entry in the chain. */ |
3476
|
|
|
|
|
|
PL_compiling.cop_hints_hash |
3477
|
26
|
|
|
|
|
= cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); |
3478
|
|
|
|
|
|
/* Check the assumption that this removed the label. */ |
3479
|
|
|
|
|
|
assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); |
3480
|
|
|
|
|
|
} |
3481
|
|
|
|
|
|
else |
3482
|
3759846
|
|
|
|
|
PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); |
3483
|
|
|
|
|
|
} |
3484
|
|
|
|
|
|
|
3485
|
4629661
|
100
|
|
|
|
CALL_BLOCK_HOOKS(bhk_eval, saveop); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3486
|
|
|
|
|
|
|
3487
|
|
|
|
|
|
/* note that yyparse() may raise an exception, e.g. C, |
3488
|
|
|
|
|
|
* so honour CATCH_GET and trap it here if necessary */ |
3489
|
|
|
|
|
|
|
3490
|
4350983
|
100
|
|
|
|
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); |
|
|
100
|
|
|
|
|
3491
|
|
|
|
|
|
|
3492
|
4288861
|
100
|
|
|
|
if (yystatus || PL_parser->error_count || !PL_eval_root) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3493
|
|
|
|
|
|
SV **newsp; /* Used by POPBLOCK. */ |
3494
|
|
|
|
|
|
PERL_CONTEXT *cx; |
3495
|
|
|
|
|
|
I32 optype; /* Used by POPEVAL. */ |
3496
|
|
|
|
|
|
SV *namesv; |
3497
|
|
|
|
|
|
SV *errsv = NULL; |
3498
|
|
|
|
|
|
|
3499
|
|
|
|
|
|
cx = NULL; |
3500
|
|
|
|
|
|
namesv = NULL; |
3501
|
|
|
|
|
|
PERL_UNUSED_VAR(newsp); |
3502
|
|
|
|
|
|
PERL_UNUSED_VAR(optype); |
3503
|
|
|
|
|
|
|
3504
|
|
|
|
|
|
/* note that if yystatus == 3, then the EVAL CX block has already |
3505
|
|
|
|
|
|
* been popped, and various vars restored */ |
3506
|
1262
|
|
|
|
|
PL_op = saveop; |
3507
|
1262
|
100
|
|
|
|
if (yystatus != 3) { |
3508
|
1248
|
100
|
|
|
|
if (PL_eval_root) { |
3509
|
1186
|
|
|
|
|
op_free(PL_eval_root); |
3510
|
1186
|
|
|
|
|
PL_eval_root = NULL; |
3511
|
|
|
|
|
|
} |
3512
|
1248
|
|
|
|
|
SP = PL_stack_base + POPMARK; /* pop original mark */ |
3513
|
1248
|
|
|
|
|
POPBLOCK(cx,PL_curpm); |
3514
|
1248
|
50
|
|
|
|
POPEVAL(cx); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3515
|
1248
|
|
|
|
|
namesv = cx->blk_eval.old_namesv; |
3516
|
|
|
|
|
|
/* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */ |
3517
|
1248
|
|
|
|
|
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ |
3518
|
|
|
|
|
|
} |
3519
|
|
|
|
|
|
|
3520
|
1262
|
50
|
|
|
|
errsv = ERRSV; |
3521
|
1262
|
100
|
|
|
|
if (in_require) { |
3522
|
22
|
50
|
|
|
|
if (!cx) { |
3523
|
|
|
|
|
|
/* If cx is still NULL, it means that we didn't go in the |
3524
|
|
|
|
|
|
* POPEVAL branch. */ |
3525
|
0
|
|
|
|
|
cx = &cxstack[cxstack_ix]; |
3526
|
|
|
|
|
|
assert(CxTYPE(cx) == CXt_EVAL); |
3527
|
0
|
|
|
|
|
namesv = cx->blk_eval.old_namesv; |
3528
|
|
|
|
|
|
} |
3529
|
22
|
50
|
|
|
|
(void)hv_store(GvHVn(PL_incgv), |
|
|
50
|
|
|
|
|
3530
|
|
|
|
|
|
SvPVX_const(namesv), |
3531
|
|
|
|
|
|
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), |
3532
|
|
|
|
|
|
&PL_sv_undef, 0); |
3533
|
22
|
50
|
|
|
|
Perl_croak(aTHX_ "%"SVf"Compilation failed in require", |
3534
|
|
|
|
|
|
SVfARG(errsv |
3535
|
|
|
|
|
|
? errsv |
3536
|
|
|
|
|
|
: newSVpvs_flags("Unknown error\n", SVs_TEMP))); |
3537
|
|
|
|
|
|
} |
3538
|
|
|
|
|
|
else { |
3539
|
1240
|
50
|
|
|
|
if (!*(SvPV_nolen_const(errsv))) { |
|
|
50
|
|
|
|
|
3540
|
0
|
|
|
|
|
sv_setpvs(errsv, "Compilation error"); |
3541
|
|
|
|
|
|
} |
3542
|
|
|
|
|
|
} |
3543
|
1240
|
100
|
|
|
|
if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); |
3544
|
1240
|
|
|
|
|
PUTBACK; |
3545
|
1240
|
|
|
|
|
return FALSE; |
3546
|
|
|
|
|
|
} |
3547
|
|
|
|
|
|
else |
3548
|
4287599
|
|
|
|
|
LEAVE_with_name("evalcomp"); |
3549
|
|
|
|
|
|
|
3550
|
4287599
|
|
|
|
|
CopLINE_set(&PL_compiling, 0); |
3551
|
4287599
|
|
|
|
|
SAVEFREEOP(PL_eval_root); |
3552
|
4287599
|
|
|
|
|
cv_forget_slab(evalcv); |
3553
|
|
|
|
|
|
|
3554
|
|
|
|
|
|
DEBUG_x(dump_eval()); |
3555
|
|
|
|
|
|
|
3556
|
|
|
|
|
|
/* Register with debugger: */ |
3557
|
4287599
|
100
|
|
|
|
if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3558
|
3150
|
|
|
|
|
CV * const cv = get_cvs("DB::postponed", 0); |
3559
|
3150
|
100
|
|
|
|
if (cv) { |
3560
|
768
|
|
|
|
|
dSP; |
3561
|
768
|
50
|
|
|
|
PUSHMARK(SP); |
3562
|
768
|
50
|
|
|
|
XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); |
3563
|
768
|
|
|
|
|
PUTBACK; |
3564
|
768
|
|
|
|
|
call_sv(MUTABLE_SV(cv), G_DISCARD); |
3565
|
|
|
|
|
|
} |
3566
|
|
|
|
|
|
} |
3567
|
|
|
|
|
|
|
3568
|
4287599
|
50
|
|
|
|
if (PL_unitcheckav) { |
3569
|
4287599
|
|
|
|
|
OP *es = PL_eval_start; |
3570
|
4287599
|
|
|
|
|
call_list(PL_scopestack_ix, PL_unitcheckav); |
3571
|
4287599
|
|
|
|
|
PL_eval_start = es; |
3572
|
|
|
|
|
|
} |
3573
|
|
|
|
|
|
|
3574
|
|
|
|
|
|
/* compiled okay, so do it */ |
3575
|
|
|
|
|
|
|
3576
|
4287599
|
|
|
|
|
CvDEPTH(evalcv) = 1; |
3577
|
4287599
|
|
|
|
|
SP = PL_stack_base + POPMARK; /* pop original mark */ |
3578
|
4287599
|
|
|
|
|
PL_op = saveop; /* The caller may need it. */ |
3579
|
4287599
|
|
|
|
|
PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ |
3580
|
|
|
|
|
|
|
3581
|
4287599
|
|
|
|
|
PUTBACK; |
3582
|
4288219
|
|
|
|
|
return TRUE; |
3583
|
|
|
|
|
|
} |
3584
|
|
|
|
|
|
|
3585
|
|
|
|
|
|
STATIC PerlIO * |
3586
|
3071434
|
|
|
|
|
S_check_type_and_open(pTHX_ SV *name) |
3587
|
|
|
|
|
|
{ |
3588
|
|
|
|
|
|
Stat_t st; |
3589
|
3071434
|
50
|
|
|
|
const char *p = SvPV_nolen_const(name); |
3590
|
|
|
|
|
|
int st_rc; |
3591
|
|
|
|
|
|
|
3592
|
|
|
|
|
|
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; |
3593
|
|
|
|
|
|
|
3594
|
|
|
|
|
|
/* checking here captures a reasonable error message when |
3595
|
|
|
|
|
|
* PERL_DISABLE_PMC is true, but when PMC checks are enabled, the |
3596
|
|
|
|
|
|
* user gets a confusing message about looking for the .pmc file |
3597
|
|
|
|
|
|
* rather than for the .pm file. |
3598
|
|
|
|
|
|
* This check prevents a \0 in @INC causing problems. |
3599
|
|
|
|
|
|
*/ |
3600
|
3071434
|
50
|
|
|
|
if (!IS_SAFE_PATHNAME(name, "require")) |
3601
|
|
|
|
|
|
return NULL; |
3602
|
|
|
|
|
|
|
3603
|
|
|
|
|
|
st_rc = PerlLIO_stat(p, &st); |
3604
|
|
|
|
|
|
|
3605
|
3071434
|
100
|
|
|
|
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3606
|
|
|
|
|
|
return NULL; |
3607
|
|
|
|
|
|
} |
3608
|
|
|
|
|
|
|
3609
|
|
|
|
|
|
#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) |
3610
|
1868256
|
|
|
|
|
return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); |
3611
|
|
|
|
|
|
#else |
3612
|
|
|
|
|
|
return PerlIO_open(p, PERL_SCRIPT_MODE); |
3613
|
|
|
|
|
|
#endif |
3614
|
|
|
|
|
|
} |
3615
|
|
|
|
|
|
|
3616
|
|
|
|
|
|
#ifndef PERL_DISABLE_PMC |
3617
|
|
|
|
|
|
STATIC PerlIO * |
3618
|
3071436
|
|
|
|
|
S_doopen_pm(pTHX_ SV *name) |
3619
|
|
|
|
|
|
{ |
3620
|
|
|
|
|
|
STRLEN namelen; |
3621
|
3071436
|
50
|
|
|
|
const char *p = SvPV_const(name, namelen); |
3622
|
|
|
|
|
|
|
3623
|
|
|
|
|
|
PERL_ARGS_ASSERT_DOOPEN_PM; |
3624
|
|
|
|
|
|
|
3625
|
|
|
|
|
|
/* check the name before trying for the .pmc name to avoid the |
3626
|
|
|
|
|
|
* warning referring to the .pmc which the user probably doesn't |
3627
|
|
|
|
|
|
* know or care about |
3628
|
|
|
|
|
|
*/ |
3629
|
3071436
|
100
|
|
|
|
if (!IS_SAFE_PATHNAME(name, "require")) |
3630
|
|
|
|
|
|
return NULL; |
3631
|
|
|
|
|
|
|
3632
|
3071434
|
100
|
|
|
|
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { |
|
|
100
|
|
|
|
|
3633
|
2923876
|
|
|
|
|
SV *const pmcsv = sv_newmortal(); |
3634
|
|
|
|
|
|
Stat_t pmcstat; |
3635
|
|
|
|
|
|
|
3636
|
2923876
|
50
|
|
|
|
SvSetSV_nosteal(pmcsv,name); |
3637
|
2923876
|
|
|
|
|
sv_catpvn(pmcsv, "c", 1); |
3638
|
|
|
|
|
|
|
3639
|
5847752
|
50
|
|
|
|
if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0) |
|
|
100
|
|
|
|
|
3640
|
8
|
|
|
|
|
return check_type_and_open(pmcsv); |
3641
|
|
|
|
|
|
} |
3642
|
3071431
|
|
|
|
|
return check_type_and_open(name); |
3643
|
|
|
|
|
|
} |
3644
|
|
|
|
|
|
#else |
3645
|
|
|
|
|
|
# define doopen_pm(name) check_type_and_open(name) |
3646
|
|
|
|
|
|
#endif /* !PERL_DISABLE_PMC */ |
3647
|
|
|
|
|
|
|
3648
|
|
|
|
|
|
/* require doesn't search for absolute names, or when the name is |
3649
|
|
|
|
|
|
explicity relative the current directory */ |
3650
|
|
|
|
|
|
PERL_STATIC_INLINE bool |
3651
|
|
|
|
|
|
S_path_is_searchable(const char *name) |
3652
|
|
|
|
|
|
{ |
3653
|
|
|
|
|
|
PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE; |
3654
|
|
|
|
|
|
|
3655
|
6570031
|
100
|
|
|
|
if (PERL_FILE_IS_ABSOLUTE(name) |
3656
|
|
|
|
|
|
#ifdef WIN32 |
3657
|
|
|
|
|
|
|| (*name == '.' && ((name[1] == '/' || |
3658
|
|
|
|
|
|
(name[1] == '.' && name[2] == '/')) |
3659
|
|
|
|
|
|
|| (name[1] == '\\' || |
3660
|
|
|
|
|
|
( name[1] == '.' && name[2] == '\\'))) |
3661
|
|
|
|
|
|
) |
3662
|
|
|
|
|
|
#else |
3663
|
6571566
|
100
|
|
|
|
|| (*name == '.' && (name[1] == '/' || |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3664
|
3341844
|
50
|
|
|
|
(name[1] == '.' && name[2] == '/'))) |
3665
|
|
|
|
|
|
#endif |
3666
|
|
|
|
|
|
) |
3667
|
|
|
|
|
|
{ |
3668
|
|
|
|
|
|
return FALSE; |
3669
|
|
|
|
|
|
} |
3670
|
|
|
|
|
|
else |
3671
|
|
|
|
|
|
return TRUE; |
3672
|
|
|
|
|
|
} |
3673
|
|
|
|
|
|
|
3674
|
6728743
|
|
|
|
|
PP(pp_require) |
3675
|
|
|
|
|
|
{ |
3676
|
6728743
|
|
|
|
|
dVAR; dSP; |
3677
|
|
|
|
|
|
PERL_CONTEXT *cx; |
3678
|
|
|
|
|
|
SV *sv; |
3679
|
|
|
|
|
|
const char *name; |
3680
|
|
|
|
|
|
STRLEN len; |
3681
|
|
|
|
|
|
char * unixname; |
3682
|
|
|
|
|
|
STRLEN unixlen; |
3683
|
|
|
|
|
|
#ifdef VMS |
3684
|
|
|
|
|
|
int vms_unixname = 0; |
3685
|
|
|
|
|
|
char *unixnamebuf; |
3686
|
|
|
|
|
|
char *unixdir; |
3687
|
|
|
|
|
|
char *unixdirbuf; |
3688
|
|
|
|
|
|
#endif |
3689
|
|
|
|
|
|
const char *tryname = NULL; |
3690
|
|
|
|
|
|
SV *namesv = NULL; |
3691
|
6728743
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
3692
|
|
|
|
|
|
int filter_has_file = 0; |
3693
|
|
|
|
|
|
PerlIO *tryrsfp = NULL; |
3694
|
|
|
|
|
|
SV *filter_cache = NULL; |
3695
|
|
|
|
|
|
SV *filter_state = NULL; |
3696
|
|
|
|
|
|
SV *filter_sub = NULL; |
3697
|
|
|
|
|
|
SV *hook_sv = NULL; |
3698
|
|
|
|
|
|
SV *encoding; |
3699
|
|
|
|
|
|
OP *op; |
3700
|
|
|
|
|
|
int saved_errno; |
3701
|
|
|
|
|
|
bool path_searchable; |
3702
|
|
|
|
|
|
|
3703
|
6728743
|
|
|
|
|
sv = POPs; |
3704
|
6728743
|
100
|
|
|
|
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3705
|
158686
|
|
|
|
|
sv = sv_2mortal(new_version(sv)); |
3706
|
158686
|
100
|
|
|
|
if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) |
3707
|
17238
|
|
|
|
|
upg_version(PL_patchlevel, TRUE); |
3708
|
158686
|
100
|
|
|
|
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { |
|
|
100
|
|
|
|
|
3709
|
34
|
100
|
|
|
|
if ( vcmp(sv,PL_patchlevel) <= 0 ) |
3710
|
18
|
|
|
|
|
DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", |
3711
|
18
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(sv))), |
3712
|
18
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(PL_patchlevel))) |
3713
|
|
|
|
|
|
); |
3714
|
|
|
|
|
|
} |
3715
|
|
|
|
|
|
else { |
3716
|
158652
|
100
|
|
|
|
if ( vcmp(sv,PL_patchlevel) > 0 ) { |
3717
|
|
|
|
|
|
I32 first = 0; |
3718
|
|
|
|
|
|
AV *lav; |
3719
|
36
|
|
|
|
|
SV * const req = SvRV(sv); |
3720
|
36
|
|
|
|
|
SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); |
3721
|
|
|
|
|
|
|
3722
|
|
|
|
|
|
/* get the left hand term */ |
3723
|
36
|
|
|
|
|
lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); |
3724
|
|
|
|
|
|
|
3725
|
36
|
50
|
|
|
|
first = SvIV(*av_fetch(lav,0,0)); |
3726
|
36
|
100
|
|
|
|
if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ |
3727
|
20
|
100
|
|
|
|
|| hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ |
3728
|
16
|
100
|
|
|
|
|| av_len(lav) > 1 /* FP with > 3 digits */ |
3729
|
10
|
50
|
|
|
|
|| strstr(SvPVX(pv),".0") /* FP with leading 0 */ |
3730
|
|
|
|
|
|
) { |
3731
|
26
|
|
|
|
|
DIE(aTHX_ "Perl %"SVf" required--this is only " |
3732
|
|
|
|
|
|
"%"SVf", stopped", |
3733
|
26
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(req))), |
3734
|
26
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(PL_patchlevel))) |
3735
|
|
|
|
|
|
); |
3736
|
|
|
|
|
|
} |
3737
|
|
|
|
|
|
else { /* probably 'use 5.10' or 'use 5.8' */ |
3738
|
|
|
|
|
|
SV *hintsv; |
3739
|
|
|
|
|
|
I32 second = 0; |
3740
|
|
|
|
|
|
|
3741
|
10
|
50
|
|
|
|
if (av_len(lav)>=1) |
3742
|
10
|
50
|
|
|
|
second = SvIV(*av_fetch(lav,1,0)); |
3743
|
|
|
|
|
|
|
3744
|
10
|
100
|
|
|
|
second /= second >= 600 ? 100 : 10; |
3745
|
10
|
|
|
|
|
hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", |
3746
|
|
|
|
|
|
(int)first, (int)second); |
3747
|
10
|
|
|
|
|
upg_version(hintsv, TRUE); |
3748
|
|
|
|
|
|
|
3749
|
10
|
|
|
|
|
DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" |
3750
|
|
|
|
|
|
"--this is only %"SVf", stopped", |
3751
|
10
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(req))), |
3752
|
10
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), |
3753
|
10
|
|
|
|
|
SVfARG(sv_2mortal(vnormal(PL_patchlevel))) |
3754
|
|
|
|
|
|
); |
3755
|
|
|
|
|
|
} |
3756
|
|
|
|
|
|
} |
3757
|
|
|
|
|
|
} |
3758
|
|
|
|
|
|
|
3759
|
158632
|
|
|
|
|
RETPUSHYES; |
3760
|
|
|
|
|
|
} |
3761
|
6570057
|
100
|
|
|
|
name = SvPV_const(sv, len); |
3762
|
6570057
|
50
|
|
|
|
if (!(name && len > 0 && *name)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3763
|
20
|
|
|
|
|
DIE(aTHX_ "Null filename used"); |
3764
|
6570037
|
100
|
|
|
|
if (!IS_SAFE_PATHNAME(sv, "require")) { |
3765
|
18
|
50
|
|
|
|
DIE(aTHX_ "Can't locate %s: %s", |
3766
|
24
|
|
|
|
|
pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv), |
3767
|
|
|
|
|
|
SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), |
3768
|
|
|
|
|
|
Strerror(ENOENT)); |
3769
|
|
|
|
|
|
} |
3770
|
6570031
|
100
|
|
|
|
TAINT_PROPER("require"); |
3771
|
|
|
|
|
|
|
3772
|
|
|
|
|
|
path_searchable = path_is_searchable(name); |
3773
|
|
|
|
|
|
|
3774
|
|
|
|
|
|
#ifdef VMS |
3775
|
|
|
|
|
|
/* The key in the %ENV hash is in the syntax of file passed as the argument |
3776
|
|
|
|
|
|
* usually this is in UNIX format, but sometimes in VMS format, which |
3777
|
|
|
|
|
|
* can result in a module being pulled in more than once. |
3778
|
|
|
|
|
|
* To prevent this, the key must be stored in UNIX format if the VMS |
3779
|
|
|
|
|
|
* name can be translated to UNIX. |
3780
|
|
|
|
|
|
*/ |
3781
|
|
|
|
|
|
|
3782
|
|
|
|
|
|
if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) |
3783
|
|
|
|
|
|
&& (unixname = tounixspec(name, unixnamebuf)) != NULL) { |
3784
|
|
|
|
|
|
unixlen = strlen(unixname); |
3785
|
|
|
|
|
|
vms_unixname = 1; |
3786
|
|
|
|
|
|
} |
3787
|
|
|
|
|
|
else |
3788
|
|
|
|
|
|
#endif |
3789
|
|
|
|
|
|
{ |
3790
|
|
|
|
|
|
/* if not VMS or VMS name can not be translated to UNIX, pass it |
3791
|
|
|
|
|
|
* through. |
3792
|
|
|
|
|
|
*/ |
3793
|
|
|
|
|
|
unixname = (char *) name; |
3794
|
6570031
|
|
|
|
|
unixlen = len; |
3795
|
|
|
|
|
|
} |
3796
|
6570031
|
100
|
|
|
|
if (PL_op->op_type == OP_REQUIRE) { |
3797
|
6547953
|
50
|
|
|
|
SV * const * const svp = hv_fetch(GvHVn(PL_incgv), |
3798
|
|
|
|
|
|
unixname, unixlen, 0); |
3799
|
6547953
|
100
|
|
|
|
if ( svp ) { |
3800
|
5937091
|
100
|
|
|
|
if (*svp != &PL_sv_undef) |
3801
|
5936445
|
|
|
|
|
RETPUSHYES; |
3802
|
|
|
|
|
|
else |
3803
|
646
|
|
|
|
|
DIE(aTHX_ "Attempt to reload %s aborted.\n" |
3804
|
|
|
|
|
|
"Compilation failed in require", unixname); |
3805
|
|
|
|
|
|
} |
3806
|
|
|
|
|
|
} |
3807
|
|
|
|
|
|
|
3808
|
|
|
|
|
|
LOADING_FILE_PROBE(unixname); |
3809
|
|
|
|
|
|
|
3810
|
|
|
|
|
|
/* prepare to compile file */ |
3811
|
|
|
|
|
|
|
3812
|
632940
|
100
|
|
|
|
if (!path_searchable) { |
3813
|
|
|
|
|
|
/* At this point, name is SvPVX(sv) */ |
3814
|
|
|
|
|
|
tryname = name; |
3815
|
12510
|
|
|
|
|
tryrsfp = doopen_pm(sv); |
3816
|
|
|
|
|
|
} |
3817
|
632940
|
100
|
|
|
|
if (!tryrsfp && !(errno == EACCES && !path_searchable)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3818
|
620448
|
50
|
|
|
|
AV * const ar = GvAVn(PL_incgv); |
3819
|
|
|
|
|
|
SSize_t i; |
3820
|
|
|
|
|
|
#ifdef VMS |
3821
|
|
|
|
|
|
if (vms_unixname) |
3822
|
|
|
|
|
|
#endif |
3823
|
|
|
|
|
|
{ |
3824
|
620448
|
|
|
|
|
namesv = newSV_type(SVt_PV); |
3825
|
3101033
|
100
|
|
|
|
for (i = 0; i <= AvFILL(ar); i++) { |
|
|
100
|
|
|
|
|
3826
|
3059216
|
|
|
|
|
SV * const dirsv = *av_fetch(ar, i, TRUE); |
3827
|
|
|
|
|
|
|
3828
|
3059216
|
100
|
|
|
|
if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) |
|
|
50
|
|
|
|
|
3829
|
214
|
|
|
|
|
mg_get(dirsv); |
3830
|
3059452
|
|
|
|
|
if (SvROK(dirsv)) { |
3831
|
|
|
|
|
|
int count; |
3832
|
|
|
|
|
|
SV **svp; |
3833
|
|
|
|
|
|
SV *loader = dirsv; |
3834
|
|
|
|
|
|
|
3835
|
236
|
100
|
|
|
|
if (SvTYPE(SvRV(loader)) == SVt_PVAV |
3836
|
20
|
100
|
|
|
|
&& !sv_isobject(loader)) |
3837
|
|
|
|
|
|
{ |
3838
|
16
|
|
|
|
|
loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); |
3839
|
|
|
|
|
|
} |
3840
|
|
|
|
|
|
|
3841
|
236
|
|
|
|
|
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", |
3842
|
236
|
|
|
|
|
PTR2UV(SvRV(dirsv)), name); |
3843
|
236
|
|
|
|
|
tryname = SvPVX_const(namesv); |
3844
|
|
|
|
|
|
tryrsfp = NULL; |
3845
|
|
|
|
|
|
|
3846
|
236
|
|
|
|
|
ENTER_with_name("call_INC"); |
3847
|
236
|
|
|
|
|
SAVETMPS; |
3848
|
118
|
|
|
|
|
EXTEND(SP, 2); |
3849
|
|
|
|
|
|
|
3850
|
236
|
50
|
|
|
|
PUSHMARK(SP); |
3851
|
236
|
|
|
|
|
PUSHs(dirsv); |
3852
|
236
|
|
|
|
|
PUSHs(sv); |
3853
|
236
|
|
|
|
|
PUTBACK; |
3854
|
236
|
100
|
|
|
|
if (sv_isobject(loader)) |
3855
|
12
|
|
|
|
|
count = call_method("INC", G_ARRAY); |
3856
|
|
|
|
|
|
else |
3857
|
224
|
|
|
|
|
count = call_sv(loader, G_ARRAY); |
3858
|
228
|
|
|
|
|
SPAGAIN; |
3859
|
|
|
|
|
|
|
3860
|
228
|
100
|
|
|
|
if (count > 0) { |
3861
|
|
|
|
|
|
int i = 0; |
3862
|
|
|
|
|
|
SV *arg; |
3863
|
|
|
|
|
|
|
3864
|
224
|
|
|
|
|
SP -= count - 1; |
3865
|
224
|
|
|
|
|
arg = SP[i++]; |
3866
|
|
|
|
|
|
|
3867
|
224
|
100
|
|
|
|
if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) |
|
|
100
|
|
|
|
|
3868
|
144
|
100
|
|
|
|
&& !isGV_with_GP(SvRV(arg))) { |
|
|
50
|
|
|
|
|
3869
|
20
|
|
|
|
|
filter_cache = SvRV(arg); |
3870
|
|
|
|
|
|
|
3871
|
20
|
100
|
|
|
|
if (i < count) { |
3872
|
10
|
|
|
|
|
arg = SP[i++]; |
3873
|
|
|
|
|
|
} |
3874
|
|
|
|
|
|
} |
3875
|
|
|
|
|
|
|
3876
|
224
|
100
|
|
|
|
if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3877
|
130
|
|
|
|
|
arg = SvRV(arg); |
3878
|
|
|
|
|
|
} |
3879
|
|
|
|
|
|
|
3880
|
224
|
100
|
|
|
|
if (isGV_with_GP(arg)) { |
|
|
50
|
|
|
|
|
3881
|
130
|
50
|
|
|
|
IO * const io = GvIO((const GV *)arg); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3882
|
|
|
|
|
|
|
3883
|
|
|
|
|
|
++filter_has_file; |
3884
|
|
|
|
|
|
|
3885
|
130
|
50
|
|
|
|
if (io) { |
3886
|
130
|
|
|
|
|
tryrsfp = IoIFP(io); |
3887
|
130
|
50
|
|
|
|
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { |
|
|
0
|
|
|
|
|
3888
|
0
|
|
|
|
|
PerlIO_close(IoOFP(io)); |
3889
|
|
|
|
|
|
} |
3890
|
130
|
|
|
|
|
IoIFP(io) = NULL; |
3891
|
130
|
|
|
|
|
IoOFP(io) = NULL; |
3892
|
|
|
|
|
|
} |
3893
|
|
|
|
|
|
|
3894
|
130
|
100
|
|
|
|
if (i < count) { |
3895
|
44
|
|
|
|
|
arg = SP[i++]; |
3896
|
|
|
|
|
|
} |
3897
|
|
|
|
|
|
} |
3898
|
|
|
|
|
|
|
3899
|
224
|
100
|
|
|
|
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { |
|
|
100
|
|
|
|
|
3900
|
|
|
|
|
|
filter_sub = arg; |
3901
|
76
|
|
|
|
|
SvREFCNT_inc_simple_void_NN(filter_sub); |
3902
|
|
|
|
|
|
|
3903
|
76
|
100
|
|
|
|
if (i < count) { |
3904
|
42
|
|
|
|
|
filter_state = SP[i]; |
3905
|
42
|
50
|
|
|
|
SvREFCNT_inc_simple_void(filter_state); |
3906
|
|
|
|
|
|
} |
3907
|
|
|
|
|
|
} |
3908
|
|
|
|
|
|
|
3909
|
224
|
100
|
|
|
|
if (!tryrsfp && (filter_cache || filter_sub)) { |
|
|
100
|
|
|
|
|
3910
|
42
|
|
|
|
|
tryrsfp = PerlIO_open(BIT_BUCKET, |
3911
|
|
|
|
|
|
PERL_SCRIPT_MODE); |
3912
|
|
|
|
|
|
} |
3913
|
224
|
|
|
|
|
SP--; |
3914
|
|
|
|
|
|
} |
3915
|
|
|
|
|
|
|
3916
|
228
|
|
|
|
|
PUTBACK; |
3917
|
228
|
100
|
|
|
|
FREETMPS; |
3918
|
228
|
|
|
|
|
LEAVE_with_name("call_INC"); |
3919
|
|
|
|
|
|
|
3920
|
|
|
|
|
|
/* Adjust file name if the hook has set an %INC entry. |
3921
|
|
|
|
|
|
This needs to happen after the FREETMPS above. */ |
3922
|
228
|
50
|
|
|
|
svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); |
3923
|
228
|
100
|
|
|
|
if (svp) |
3924
|
24
|
100
|
|
|
|
tryname = SvPV_nolen_const(*svp); |
3925
|
|
|
|
|
|
|
3926
|
228
|
100
|
|
|
|
if (tryrsfp) { |
3927
|
|
|
|
|
|
hook_sv = dirsv; |
3928
|
|
|
|
|
|
break; |
3929
|
|
|
|
|
|
} |
3930
|
|
|
|
|
|
|
3931
|
|
|
|
|
|
filter_has_file = 0; |
3932
|
|
|
|
|
|
filter_cache = NULL; |
3933
|
56
|
50
|
|
|
|
if (filter_state) { |
3934
|
0
|
|
|
|
|
SvREFCNT_dec(filter_state); |
3935
|
|
|
|
|
|
filter_state = NULL; |
3936
|
|
|
|
|
|
} |
3937
|
56
|
50
|
|
|
|
if (filter_sub) { |
3938
|
0
|
|
|
|
|
SvREFCNT_dec(filter_sub); |
3939
|
|
|
|
|
|
filter_sub = NULL; |
3940
|
|
|
|
|
|
} |
3941
|
|
|
|
|
|
} |
3942
|
|
|
|
|
|
else { |
3943
|
3058980
|
100
|
|
|
|
if (path_searchable) { |
3944
|
|
|
|
|
|
const char *dir; |
3945
|
|
|
|
|
|
STRLEN dirlen; |
3946
|
|
|
|
|
|
|
3947
|
3058926
|
50
|
|
|
|
if (SvOK(dirsv)) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3948
|
3058926
|
50
|
|
|
|
dir = SvPV_const(dirsv, dirlen); |
3949
|
|
|
|
|
|
} else { |
3950
|
|
|
|
|
|
dir = ""; |
3951
|
0
|
|
|
|
|
dirlen = 0; |
3952
|
|
|
|
|
|
} |
3953
|
|
|
|
|
|
|
3954
|
|
|
|
|
|
#ifdef VMS |
3955
|
|
|
|
|
|
if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL) |
3956
|
|
|
|
|
|
|| ((unixdir = tounixpath(dir, unixdirbuf)) == NULL)) |
3957
|
|
|
|
|
|
continue; |
3958
|
|
|
|
|
|
sv_setpv(namesv, unixdir); |
3959
|
|
|
|
|
|
sv_catpv(namesv, unixname); |
3960
|
|
|
|
|
|
#else |
3961
|
|
|
|
|
|
# ifdef __SYMBIAN32__ |
3962
|
|
|
|
|
|
if (PL_origfilename[0] && |
3963
|
|
|
|
|
|
PL_origfilename[1] == ':' && |
3964
|
|
|
|
|
|
!(dir[0] && dir[1] == ':')) |
3965
|
|
|
|
|
|
Perl_sv_setpvf(aTHX_ namesv, |
3966
|
|
|
|
|
|
"%c:%s\\%s", |
3967
|
|
|
|
|
|
PL_origfilename[0], |
3968
|
|
|
|
|
|
dir, name); |
3969
|
|
|
|
|
|
else |
3970
|
|
|
|
|
|
Perl_sv_setpvf(aTHX_ namesv, |
3971
|
|
|
|
|
|
"%s\\%s", |
3972
|
|
|
|
|
|
dir, name); |
3973
|
|
|
|
|
|
# else |
3974
|
|
|
|
|
|
/* The equivalent of |
3975
|
|
|
|
|
|
Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); |
3976
|
|
|
|
|
|
but without the need to parse the format string, or |
3977
|
|
|
|
|
|
call strlen on either pointer, and with the correct |
3978
|
|
|
|
|
|
allocation up front. */ |
3979
|
|
|
|
|
|
{ |
3980
|
3058926
|
100
|
|
|
|
char *tmp = SvGROW(namesv, dirlen + len + 2); |
|
|
100
|
|
|
|
|
3981
|
|
|
|
|
|
|
3982
|
3058926
|
|
|
|
|
memcpy(tmp, dir, dirlen); |
3983
|
3058926
|
|
|
|
|
tmp +=dirlen; |
3984
|
|
|
|
|
|
|
3985
|
|
|
|
|
|
/* Avoid '//' */ |
3986
|
3058926
|
50
|
|
|
|
if (!dirlen || *(tmp-1) != '/') { |
|
|
100
|
|
|
|
|
3987
|
3058436
|
|
|
|
|
*tmp++ = '/'; |
3988
|
|
|
|
|
|
} |
3989
|
|
|
|
|
|
|
3990
|
|
|
|
|
|
/* name came from an SV, so it will have a '\0' at the |
3991
|
|
|
|
|
|
end that we can copy as part of this memcpy(). */ |
3992
|
3058926
|
|
|
|
|
memcpy(tmp, name, len + 1); |
3993
|
|
|
|
|
|
|
3994
|
3058926
|
|
|
|
|
SvCUR_set(namesv, dirlen + len + 1); |
3995
|
3058926
|
|
|
|
|
SvPOK_on(namesv); |
3996
|
|
|
|
|
|
} |
3997
|
|
|
|
|
|
# endif |
3998
|
|
|
|
|
|
#endif |
3999
|
3058926
|
100
|
|
|
|
TAINT_PROPER("require"); |
4000
|
3058926
|
|
|
|
|
tryname = SvPVX_const(namesv); |
4001
|
3058926
|
|
|
|
|
tryrsfp = doopen_pm(namesv); |
4002
|
3058926
|
100
|
|
|
|
if (tryrsfp) { |
4003
|
578449
|
100
|
|
|
|
if (tryname[0] == '.' && tryname[1] == '/') { |
|
|
100
|
|
|
|
|
4004
|
4776
|
|
|
|
|
++tryname; |
4005
|
4776
|
50
|
|
|
|
while (*++tryname == '/') {} |
4006
|
|
|
|
|
|
} |
4007
|
|
|
|
|
|
break; |
4008
|
|
|
|
|
|
} |
4009
|
2480477
|
100
|
|
|
|
else if (errno == EMFILE || errno == EACCES) { |
4010
|
|
|
|
|
|
/* no point in trying other paths if out of handles; |
4011
|
|
|
|
|
|
* on the other hand, if we couldn't open one of the |
4012
|
|
|
|
|
|
* files, then going on with the search could lead to |
4013
|
|
|
|
|
|
* unexpected results; see perl #113422 |
4014
|
|
|
|
|
|
*/ |
4015
|
|
|
|
|
|
break; |
4016
|
|
|
|
|
|
} |
4017
|
|
|
|
|
|
} |
4018
|
|
|
|
|
|
} |
4019
|
|
|
|
|
|
} |
4020
|
|
|
|
|
|
} |
4021
|
|
|
|
|
|
} |
4022
|
632932
|
|
|
|
|
saved_errno = errno; /* sv_2mortal can realloc things */ |
4023
|
632932
|
|
|
|
|
sv_2mortal(namesv); |
4024
|
632932
|
100
|
|
|
|
if (!tryrsfp) { |
4025
|
41821
|
100
|
|
|
|
if (PL_op->op_type == OP_REQUIRE) { |
4026
|
41799
|
100
|
|
|
|
if(saved_errno == EMFILE || saved_errno == EACCES) { |
4027
|
|
|
|
|
|
/* diag_listed_as: Can't locate %s */ |
4028
|
4
|
|
|
|
|
DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno)); |
4029
|
|
|
|
|
|
} else { |
4030
|
41795
|
50
|
|
|
|
if (namesv) { /* did we lookup @INC? */ |
4031
|
41795
|
50
|
|
|
|
AV * const ar = GvAVn(PL_incgv); |
4032
|
|
|
|
|
|
SSize_t i; |
4033
|
41795
|
|
|
|
|
SV *const msg = newSVpvs_flags("", SVs_TEMP); |
4034
|
41795
|
|
|
|
|
SV *const inc = newSVpvs_flags("", SVs_TEMP); |
4035
|
493258
|
100
|
|
|
|
for (i = 0; i <= AvFILL(ar); i++) { |
|
|
100
|
|
|
|
|
4036
|
451463
|
|
|
|
|
sv_catpvs(inc, " "); |
4037
|
451463
|
|
|
|
|
sv_catsv(inc, *av_fetch(ar, i, TRUE)); |
4038
|
|
|
|
|
|
} |
4039
|
83560
|
100
|
|
|
|
if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) { |
|
|
100
|
|
|
|
|
4040
|
41765
|
|
|
|
|
const char *c, *e = name + len - 3; |
4041
|
41765
|
|
|
|
|
sv_catpv(msg, " (you may need to install the "); |
4042
|
547038
|
100
|
|
|
|
for (c = name; c < e; c++) { |
4043
|
505273
|
100
|
|
|
|
if (*c == '/') { |
4044
|
41675
|
|
|
|
|
sv_catpvn(msg, "::", 2); |
4045
|
|
|
|
|
|
} |
4046
|
|
|
|
|
|
else { |
4047
|
463598
|
|
|
|
|
sv_catpvn(msg, c, 1); |
4048
|
|
|
|
|
|
} |
4049
|
|
|
|
|
|
} |
4050
|
41765
|
|
|
|
|
sv_catpv(msg, " module)"); |
4051
|
|
|
|
|
|
} |
4052
|
30
|
100
|
|
|
|
else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) { |
|
|
100
|
|
|
|
|
4053
|
4
|
|
|
|
|
sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); |
4054
|
|
|
|
|
|
} |
4055
|
26
|
100
|
|
|
|
else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) { |
|
|
100
|
|
|
|
|
4056
|
10
|
|
|
|
|
sv_catpv(msg, " (did you run h2ph?)"); |
4057
|
|
|
|
|
|
} |
4058
|
|
|
|
|
|
|
4059
|
|
|
|
|
|
/* diag_listed_as: Can't locate %s */ |
4060
|
41795
|
|
|
|
|
DIE(aTHX_ |
4061
|
|
|
|
|
|
"Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")", |
4062
|
|
|
|
|
|
name, msg, inc); |
4063
|
|
|
|
|
|
} |
4064
|
|
|
|
|
|
} |
4065
|
0
|
|
|
|
|
DIE(aTHX_ "Can't locate %s", name); |
4066
|
|
|
|
|
|
} |
4067
|
|
|
|
|
|
|
4068
|
22
|
50
|
|
|
|
CLEAR_ERRSV(); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4069
|
22
|
|
|
|
|
RETPUSHUNDEF; |
4070
|
|
|
|
|
|
} |
4071
|
|
|
|
|
|
else |
4072
|
591111
|
|
|
|
|
SETERRNO(0, SS_NORMAL); |
4073
|
|
|
|
|
|
|
4074
|
|
|
|
|
|
/* Assume success here to prevent recursive requirement. */ |
4075
|
|
|
|
|
|
/* name is never assigned to again, so len is still strlen(name) */ |
4076
|
|
|
|
|
|
/* Check whether a hook in @INC has already filled %INC */ |
4077
|
591111
|
100
|
|
|
|
if (!hook_sv) { |
4078
|
590939
|
50
|
|
|
|
(void)hv_store(GvHVn(PL_incgv), |
4079
|
|
|
|
|
|
unixname, unixlen, newSVpv(tryname,0),0); |
4080
|
|
|
|
|
|
} else { |
4081
|
172
|
50
|
|
|
|
SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); |
4082
|
172
|
100
|
|
|
|
if (!svp) |
4083
|
148
|
50
|
|
|
|
(void)hv_store(GvHVn(PL_incgv), |
4084
|
|
|
|
|
|
unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); |
4085
|
|
|
|
|
|
} |
4086
|
|
|
|
|
|
|
4087
|
591111
|
|
|
|
|
ENTER_with_name("eval"); |
4088
|
591111
|
|
|
|
|
SAVETMPS; |
4089
|
591111
|
|
|
|
|
SAVECOPFILE_FREE(&PL_compiling); |
4090
|
875869
|
|
|
|
|
CopFILE_set(&PL_compiling, tryname); |
4091
|
591111
|
|
|
|
|
lex_start(NULL, tryrsfp, 0); |
4092
|
|
|
|
|
|
|
4093
|
591111
|
100
|
|
|
|
if (filter_sub || filter_cache) { |
4094
|
|
|
|
|
|
/* We can use the SvPV of the filter PVIO itself as our cache, rather |
4095
|
|
|
|
|
|
than hanging another SV from it. In turn, filter_add() optionally |
4096
|
|
|
|
|
|
takes the SV to use as the filter (or creates a new SV if passed |
4097
|
|
|
|
|
|
NULL), so simply pass in whatever value filter_cache has. */ |
4098
|
88
|
100
|
|
|
|
SV * const fc = filter_cache ? newSV(0) : NULL; |
4099
|
|
|
|
|
|
SV *datasv; |
4100
|
88
|
100
|
|
|
|
if (fc) sv_copypv(fc, filter_cache); |
4101
|
88
|
|
|
|
|
datasv = filter_add(S_run_user_filter, fc); |
4102
|
88
|
|
|
|
|
IoLINES(datasv) = filter_has_file; |
4103
|
88
|
|
|
|
|
IoTOP_GV(datasv) = MUTABLE_GV(filter_state); |
4104
|
88
|
|
|
|
|
IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); |
4105
|
|
|
|
|
|
} |
4106
|
|
|
|
|
|
|
4107
|
|
|
|
|
|
/* switch to eval mode */ |
4108
|
591111
|
50
|
|
|
|
PUSHBLOCK(cx, CXt_EVAL, SP); |
4109
|
591111
|
50
|
|
|
|
PUSHEVAL(cx, name); |
|
|
50
|
|
|
|
|
4110
|
591111
|
|
|
|
|
cx->blk_eval.retop = PL_op->op_next; |
4111
|
|
|
|
|
|
|
4112
|
591111
|
|
|
|
|
SAVECOPLINE(&PL_compiling); |
4113
|
591111
|
|
|
|
|
CopLINE_set(&PL_compiling, 0); |
4114
|
|
|
|
|
|
|
4115
|
591111
|
|
|
|
|
PUTBACK; |
4116
|
|
|
|
|
|
|
4117
|
|
|
|
|
|
/* Store and reset encoding. */ |
4118
|
591111
|
|
|
|
|
encoding = PL_encoding; |
4119
|
591111
|
|
|
|
|
PL_encoding = NULL; |
4120
|
|
|
|
|
|
|
4121
|
591111
|
50
|
|
|
|
if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) |
4122
|
590215
|
100
|
|
|
|
op = DOCATCH(PL_eval_start); |
4123
|
|
|
|
|
|
else |
4124
|
0
|
|
|
|
|
op = PL_op->op_next; |
4125
|
|
|
|
|
|
|
4126
|
|
|
|
|
|
/* Restore encoding. */ |
4127
|
590213
|
|
|
|
|
PL_encoding = encoding; |
4128
|
|
|
|
|
|
|
4129
|
|
|
|
|
|
LOADED_FILE_PROBE(unixname); |
4130
|
|
|
|
|
|
|
4131
|
3687224
|
|
|
|
|
return op; |
4132
|
|
|
|
|
|
} |
4133
|
|
|
|
|
|
|
4134
|
|
|
|
|
|
/* This is a op added to hold the hints hash for |
4135
|
|
|
|
|
|
pp_entereval. The hash can be modified by the code |
4136
|
|
|
|
|
|
being eval'ed, so we return a copy instead. */ |
4137
|
|
|
|
|
|
|
4138
|
284240
|
|
|
|
|
PP(pp_hintseval) |
4139
|
|
|
|
|
|
{ |
4140
|
|
|
|
|
|
dVAR; |
4141
|
284240
|
|
|
|
|
dSP; |
4142
|
284240
|
50
|
|
|
|
mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv)))); |
4143
|
284240
|
|
|
|
|
RETURN; |
4144
|
|
|
|
|
|
} |
4145
|
|
|
|
|
|
|
4146
|
|
|
|
|
|
|
4147
|
3760134
|
|
|
|
|
PP(pp_entereval) |
4148
|
|
|
|
|
|
{ |
4149
|
3760134
|
|
|
|
|
dVAR; dSP; |
4150
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4151
|
|
|
|
|
|
SV *sv; |
4152
|
3760134
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
4153
|
3760134
|
|
|
|
|
const U32 was = PL_breakable_sub_gen; |
4154
|
|
|
|
|
|
char tbuf[TYPE_DIGITS(long) + 12]; |
4155
|
|
|
|
|
|
bool saved_delete = FALSE; |
4156
|
|
|
|
|
|
char *tmpbuf = tbuf; |
4157
|
|
|
|
|
|
STRLEN len; |
4158
|
|
|
|
|
|
CV* runcv; |
4159
|
|
|
|
|
|
U32 seq, lex_flags = 0; |
4160
|
|
|
|
|
|
HV *saved_hh = NULL; |
4161
|
3760134
|
|
|
|
|
const bool bytes = PL_op->op_private & OPpEVAL_BYTES; |
4162
|
|
|
|
|
|
|
4163
|
3760134
|
100
|
|
|
|
if (PL_op->op_private & OPpEVAL_HAS_HH) { |
4164
|
284240
|
|
|
|
|
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); |
4165
|
|
|
|
|
|
} |
4166
|
5192424
|
100
|
|
|
|
else if (PL_hints & HINT_LOCALIZE_HH || ( |
|
|
100
|
|
|
|
|
4167
|
3455378
|
|
|
|
|
PL_op->op_private & OPpEVAL_COPHH |
4168
|
82
|
100
|
|
|
|
&& PL_curcop->cop_hints & HINT_LOCALIZE_HH |
4169
|
|
|
|
|
|
)) { |
4170
|
20560
|
|
|
|
|
saved_hh = cop_hints_2hv(PL_curcop, 0); |
4171
|
20560
|
|
|
|
|
hv_magic(saved_hh, NULL, PERL_MAGIC_hints); |
4172
|
|
|
|
|
|
} |
4173
|
3760134
|
|
|
|
|
sv = POPs; |
4174
|
3760134
|
100
|
|
|
|
if (!SvPOK(sv)) { |
4175
|
|
|
|
|
|
/* make sure we've got a plain PV (no overload etc) before testing |
4176
|
|
|
|
|
|
* for taint. Making a copy here is probably overkill, but better |
4177
|
|
|
|
|
|
* safe than sorry */ |
4178
|
|
|
|
|
|
STRLEN len; |
4179
|
308
|
50
|
|
|
|
const char * const p = SvPV_const(sv, len); |
4180
|
|
|
|
|
|
|
4181
|
308
|
|
|
|
|
sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); |
4182
|
|
|
|
|
|
lex_flags |= LEX_START_COPIED; |
4183
|
|
|
|
|
|
|
4184
|
308
|
50
|
|
|
|
if (bytes && SvUTF8(sv)) |
|
|
0
|
|
|
|
|
4185
|
0
|
0
|
|
|
|
SvPVbyte_force(sv, len); |
4186
|
|
|
|
|
|
} |
4187
|
3759826
|
100
|
|
|
|
else if (bytes && SvUTF8(sv)) { |
|
|
100
|
|
|
|
|
4188
|
|
|
|
|
|
/* Don't modify someone else's scalar */ |
4189
|
|
|
|
|
|
STRLEN len; |
4190
|
8
|
|
|
|
|
sv = newSVsv(sv); |
4191
|
8
|
|
|
|
|
(void)sv_2mortal(sv); |
4192
|
8
|
50
|
|
|
|
SvPVbyte_force(sv,len); |
4193
|
|
|
|
|
|
lex_flags |= LEX_START_COPIED; |
4194
|
|
|
|
|
|
} |
4195
|
|
|
|
|
|
|
4196
|
3760132
|
100
|
|
|
|
TAINT_IF(SvTAINTED(sv)); |
|
|
100
|
|
|
|
|
4197
|
3760132
|
100
|
|
|
|
TAINT_PROPER("eval"); |
4198
|
|
|
|
|
|
|
4199
|
3759872
|
|
|
|
|
ENTER_with_name("eval"); |
4200
|
3759872
|
100
|
|
|
|
lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE |
|
|
100
|
|
|
|
|
4201
|
|
|
|
|
|
? LEX_IGNORE_UTF8_HINTS |
4202
|
|
|
|
|
|
: bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER |
4203
|
|
|
|
|
|
) |
4204
|
|
|
|
|
|
); |
4205
|
3759872
|
|
|
|
|
SAVETMPS; |
4206
|
|
|
|
|
|
|
4207
|
|
|
|
|
|
/* switch to eval mode */ |
4208
|
|
|
|
|
|
|
4209
|
7052178
|
100
|
|
|
|
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4210
|
3292306
|
|
|
|
|
SV * const temp_sv = sv_newmortal(); |
4211
|
9876918
|
50
|
|
|
|
Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]", |
4212
|
6584612
|
|
|
|
|
(unsigned long)++PL_evalseq, |
4213
|
9876918
|
|
|
|
|
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); |
4214
|
3292306
|
|
|
|
|
tmpbuf = SvPVX(temp_sv); |
4215
|
3292306
|
|
|
|
|
len = SvCUR(temp_sv); |
4216
|
|
|
|
|
|
} |
4217
|
|
|
|
|
|
else |
4218
|
690190
|
50
|
|
|
|
len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); |
4219
|
3759872
|
|
|
|
|
SAVECOPFILE_FREE(&PL_compiling); |
4220
|
5628649
|
|
|
|
|
CopFILE_set(&PL_compiling, tmpbuf+2); |
4221
|
3759872
|
|
|
|
|
SAVECOPLINE(&PL_compiling); |
4222
|
3759872
|
|
|
|
|
CopLINE_set(&PL_compiling, 1); |
4223
|
|
|
|
|
|
/* special case: an eval '' executed within the DB package gets lexically |
4224
|
|
|
|
|
|
* placed in the first non-DB CV rather than the current CV - this |
4225
|
|
|
|
|
|
* allows the debugger to execute code, find lexicals etc, in the |
4226
|
|
|
|
|
|
* scope of the code being debugged. Passing &seq gets find_runcv |
4227
|
|
|
|
|
|
* to do the dirty work for us */ |
4228
|
3759872
|
|
|
|
|
runcv = find_runcv(&seq); |
4229
|
|
|
|
|
|
|
4230
|
3759872
|
50
|
|
|
|
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); |
4231
|
3759872
|
50
|
|
|
|
PUSHEVAL(cx, 0); |
4232
|
3759872
|
|
|
|
|
cx->blk_eval.retop = PL_op->op_next; |
4233
|
|
|
|
|
|
|
4234
|
|
|
|
|
|
/* prepare to compile string */ |
4235
|
|
|
|
|
|
|
4236
|
3759872
|
100
|
|
|
|
if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4237
|
940
|
50
|
|
|
|
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); |
4238
|
|
|
|
|
|
else { |
4239
|
|
|
|
|
|
/* XXX For Cs within BEGIN {} blocks, this ends up |
4240
|
|
|
|
|
|
deleting the eval's FILEGV from the stash before gv_check() runs |
4241
|
|
|
|
|
|
(i.e. before run-time proper). To work around the coredump that |
4242
|
|
|
|
|
|
ensues, we always turn GvMULTI_on for any globals that were |
4243
|
|
|
|
|
|
introduced within evals. See force_ident(). GSAR 96-10-12 */ |
4244
|
3758932
|
|
|
|
|
char *const safestr = savepvn(tmpbuf, len); |
4245
|
3758932
|
|
|
|
|
SAVEDELETE(PL_defstash, safestr, len); |
4246
|
|
|
|
|
|
saved_delete = TRUE; |
4247
|
|
|
|
|
|
} |
4248
|
|
|
|
|
|
|
4249
|
3759872
|
|
|
|
|
PUTBACK; |
4250
|
|
|
|
|
|
|
4251
|
3759872
|
100
|
|
|
|
if (doeval(gimme, runcv, seq, saved_hh)) { |
4252
|
9232661
|
100
|
|
|
|
if (was != PL_breakable_sub_gen /* Some subs defined here. */ |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4253
|
3641286
|
100
|
|
|
|
? (PERLDB_LINE || PERLDB_SAVESRC) |
4254
|
1680869
|
100
|
|
|
|
: PERLDB_SAVESRC_NOSUBS) { |
4255
|
|
|
|
|
|
/* Retain the filegv we created. */ |
4256
|
3696318
|
100
|
|
|
|
} else if (!saved_delete) { |
4257
|
256
|
|
|
|
|
char *const safestr = savepvn(tmpbuf, len); |
4258
|
256
|
|
|
|
|
SAVEDELETE(PL_defstash, safestr, len); |
4259
|
|
|
|
|
|
} |
4260
|
3697384
|
100
|
|
|
|
return DOCATCH(PL_eval_start); |
4261
|
|
|
|
|
|
} else { |
4262
|
|
|
|
|
|
/* We have already left the scope set up earlier thanks to the LEAVE |
4263
|
|
|
|
|
|
in doeval(). */ |
4264
|
3100
|
100
|
|
|
|
if (was != PL_breakable_sub_gen /* Some subs defined here. */ |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4265
|
387
|
100
|
|
|
|
? (PERLDB_LINE || PERLDB_SAVESRC) |
4266
|
1448
|
100
|
|
|
|
: PERLDB_SAVESRC_INVALID) { |
4267
|
|
|
|
|
|
/* Retain the filegv we created. */ |
4268
|
1234
|
100
|
|
|
|
} else if (!saved_delete) { |
4269
|
4
|
|
|
|
|
(void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); |
4270
|
|
|
|
|
|
} |
4271
|
1860729
|
|
|
|
|
return PL_op->op_next; |
4272
|
|
|
|
|
|
} |
4273
|
|
|
|
|
|
} |
4274
|
|
|
|
|
|
|
4275
|
4270843
|
|
|
|
|
PP(pp_leaveeval) |
4276
|
|
|
|
|
|
{ |
4277
|
4270843
|
|
|
|
|
dVAR; dSP; |
4278
|
|
|
|
|
|
SV **newsp; |
4279
|
|
|
|
|
|
PMOP *newpm; |
4280
|
|
|
|
|
|
I32 gimme; |
4281
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4282
|
|
|
|
|
|
OP *retop; |
4283
|
4270843
|
|
|
|
|
const U8 save_flags = PL_op -> op_flags; |
4284
|
|
|
|
|
|
I32 optype; |
4285
|
|
|
|
|
|
SV *namesv; |
4286
|
|
|
|
|
|
CV *evalcv; |
4287
|
|
|
|
|
|
|
4288
|
4270843
|
100
|
|
|
|
PERL_ASYNC_CHECK(); |
4289
|
4270841
|
|
|
|
|
POPBLOCK(cx,newpm); |
4290
|
4270841
|
50
|
|
|
|
POPEVAL(cx); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4291
|
4270841
|
|
|
|
|
namesv = cx->blk_eval.old_namesv; |
4292
|
4270841
|
|
|
|
|
retop = cx->blk_eval.retop; |
4293
|
4270841
|
|
|
|
|
evalcv = cx->blk_eval.cv; |
4294
|
|
|
|
|
|
|
4295
|
4270841
|
|
|
|
|
TAINT_NOT; |
4296
|
4270841
|
100
|
|
|
|
SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, |
4297
|
|
|
|
|
|
gimme, SVs_TEMP); |
4298
|
4270841
|
|
|
|
|
PL_curpm = newpm; /* Don't pop $1 et al till now */ |
4299
|
|
|
|
|
|
|
4300
|
|
|
|
|
|
#ifdef DEBUGGING |
4301
|
|
|
|
|
|
assert(CvDEPTH(evalcv) == 1); |
4302
|
|
|
|
|
|
#endif |
4303
|
4270841
|
|
|
|
|
CvDEPTH(evalcv) = 0; |
4304
|
|
|
|
|
|
|
4305
|
6194021
|
100
|
|
|
|
if (optype == OP_REQUIRE && |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
4306
|
1104114
|
0
|
|
|
|
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4307
|
|
|
|
|
|
{ |
4308
|
|
|
|
|
|
/* Unassume the success we assumed earlier. */ |
4309
|
4
|
50
|
|
|
|
(void)hv_delete(GvHVn(PL_incgv), |
|
|
50
|
|
|
|
|
4310
|
|
|
|
|
|
SvPVX_const(namesv), |
4311
|
|
|
|
|
|
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), |
4312
|
|
|
|
|
|
G_DISCARD); |
4313
|
4
|
|
|
|
|
retop = Perl_die(aTHX_ "%"SVf" did not return a true value", |
4314
|
|
|
|
|
|
SVfARG(namesv)); |
4315
|
|
|
|
|
|
/* die_unwind() did LEAVE, or we won't be here */ |
4316
|
|
|
|
|
|
} |
4317
|
|
|
|
|
|
else { |
4318
|
4270837
|
|
|
|
|
LEAVE_with_name("eval"); |
4319
|
4270837
|
100
|
|
|
|
if (!(save_flags & OPf_SPECIAL)) { |
4320
|
4270835
|
50
|
|
|
|
CLEAR_ERRSV(); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4321
|
|
|
|
|
|
} |
4322
|
|
|
|
|
|
} |
4323
|
|
|
|
|
|
|
4324
|
4270837
|
|
|
|
|
RETURNOP(retop); |
4325
|
|
|
|
|
|
} |
4326
|
|
|
|
|
|
|
4327
|
|
|
|
|
|
/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it |
4328
|
|
|
|
|
|
close to the related Perl_create_eval_scope. */ |
4329
|
|
|
|
|
|
void |
4330
|
12705627
|
|
|
|
|
Perl_delete_eval_scope(pTHX) |
4331
|
|
|
|
|
|
{ |
4332
|
|
|
|
|
|
SV **newsp; |
4333
|
|
|
|
|
|
PMOP *newpm; |
4334
|
|
|
|
|
|
I32 gimme; |
4335
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4336
|
|
|
|
|
|
I32 optype; |
4337
|
|
|
|
|
|
|
4338
|
12705627
|
|
|
|
|
POPBLOCK(cx,newpm); |
4339
|
12705627
|
100
|
|
|
|
POPEVAL(cx); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4340
|
12705627
|
|
|
|
|
PL_curpm = newpm; |
4341
|
12705627
|
|
|
|
|
LEAVE_with_name("eval_scope"); |
4342
|
|
|
|
|
|
PERL_UNUSED_VAR(newsp); |
4343
|
|
|
|
|
|
PERL_UNUSED_VAR(gimme); |
4344
|
|
|
|
|
|
PERL_UNUSED_VAR(optype); |
4345
|
12705627
|
|
|
|
|
} |
4346
|
|
|
|
|
|
|
4347
|
|
|
|
|
|
/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was |
4348
|
|
|
|
|
|
also needed by Perl_fold_constants. */ |
4349
|
|
|
|
|
|
PERL_CONTEXT * |
4350
|
28139254
|
|
|
|
|
Perl_create_eval_scope(pTHX_ U32 flags) |
4351
|
|
|
|
|
|
{ |
4352
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4353
|
28139254
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
4354
|
|
|
|
|
|
|
4355
|
28139254
|
|
|
|
|
ENTER_with_name("eval_scope"); |
4356
|
28139254
|
|
|
|
|
SAVETMPS; |
4357
|
|
|
|
|
|
|
4358
|
28139254
|
100
|
|
|
|
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); |
4359
|
28139254
|
100
|
|
|
|
PUSHEVAL(cx, 0); |
4360
|
|
|
|
|
|
|
4361
|
28139254
|
|
|
|
|
PL_in_eval = EVAL_INEVAL; |
4362
|
28139254
|
100
|
|
|
|
if (flags & G_KEEPERR) |
4363
|
1699167
|
|
|
|
|
PL_in_eval |= EVAL_KEEPERR; |
4364
|
|
|
|
|
|
else |
4365
|
26440087
|
100
|
|
|
|
CLEAR_ERRSV(); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4366
|
28139254
|
100
|
|
|
|
if (flags & G_FAKINGEVAL) { |
4367
|
12732689
|
|
|
|
|
PL_eval_root = PL_op; /* Only needed so that goto works right. */ |
4368
|
|
|
|
|
|
} |
4369
|
28139254
|
|
|
|
|
return cx; |
4370
|
|
|
|
|
|
} |
4371
|
|
|
|
|
|
|
4372
|
15406565
|
|
|
|
|
PP(pp_entertry) |
4373
|
|
|
|
|
|
{ |
4374
|
|
|
|
|
|
dVAR; |
4375
|
15406565
|
|
|
|
|
PERL_CONTEXT * const cx = create_eval_scope(0); |
4376
|
15406565
|
|
|
|
|
cx->blk_eval.retop = cLOGOP->op_other->op_next; |
4377
|
15406565
|
100
|
|
|
|
return DOCATCH(PL_op->op_next); |
4378
|
|
|
|
|
|
} |
4379
|
|
|
|
|
|
|
4380
|
15183112
|
|
|
|
|
PP(pp_leavetry) |
4381
|
|
|
|
|
|
{ |
4382
|
15183112
|
|
|
|
|
dVAR; dSP; |
4383
|
|
|
|
|
|
SV **newsp; |
4384
|
|
|
|
|
|
PMOP *newpm; |
4385
|
|
|
|
|
|
I32 gimme; |
4386
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4387
|
|
|
|
|
|
I32 optype; |
4388
|
|
|
|
|
|
|
4389
|
15183112
|
100
|
|
|
|
PERL_ASYNC_CHECK(); |
4390
|
15183110
|
|
|
|
|
POPBLOCK(cx,newpm); |
4391
|
15183110
|
100
|
|
|
|
POPEVAL(cx); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4392
|
|
|
|
|
|
PERL_UNUSED_VAR(optype); |
4393
|
|
|
|
|
|
|
4394
|
15183110
|
|
|
|
|
TAINT_NOT; |
4395
|
15183110
|
|
|
|
|
SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); |
4396
|
15183110
|
|
|
|
|
PL_curpm = newpm; /* Don't pop $1 et al till now */ |
4397
|
|
|
|
|
|
|
4398
|
15183110
|
|
|
|
|
LEAVE_with_name("eval_scope"); |
4399
|
15183110
|
100
|
|
|
|
CLEAR_ERRSV(); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4400
|
15183110
|
|
|
|
|
RETURN; |
4401
|
|
|
|
|
|
} |
4402
|
|
|
|
|
|
|
4403
|
386
|
|
|
|
|
PP(pp_entergiven) |
4404
|
|
|
|
|
|
{ |
4405
|
386
|
|
|
|
|
dVAR; dSP; |
4406
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4407
|
386
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
4408
|
|
|
|
|
|
|
4409
|
386
|
|
|
|
|
ENTER_with_name("given"); |
4410
|
386
|
|
|
|
|
SAVETMPS; |
4411
|
|
|
|
|
|
|
4412
|
386
|
100
|
|
|
|
if (PL_op->op_targ) { |
4413
|
8
|
|
|
|
|
SAVEPADSVANDMORTALIZE(PL_op->op_targ); |
4414
|
8
|
|
|
|
|
SvREFCNT_dec(PAD_SVl(PL_op->op_targ)); |
4415
|
12
|
|
|
|
|
PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs); |
4416
|
|
|
|
|
|
} |
4417
|
|
|
|
|
|
else { |
4418
|
378
|
|
|
|
|
SAVE_DEFSV; |
4419
|
756
|
|
|
|
|
DEFSV_set(POPs); |
4420
|
|
|
|
|
|
} |
4421
|
|
|
|
|
|
|
4422
|
386
|
50
|
|
|
|
PUSHBLOCK(cx, CXt_GIVEN, SP); |
4423
|
386
|
|
|
|
|
PUSHGIVEN(cx); |
4424
|
|
|
|
|
|
|
4425
|
386
|
|
|
|
|
RETURN; |
4426
|
|
|
|
|
|
} |
4427
|
|
|
|
|
|
|
4428
|
366
|
|
|
|
|
PP(pp_leavegiven) |
4429
|
|
|
|
|
|
{ |
4430
|
366
|
|
|
|
|
dVAR; dSP; |
4431
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4432
|
|
|
|
|
|
I32 gimme; |
4433
|
|
|
|
|
|
SV **newsp; |
4434
|
|
|
|
|
|
PMOP *newpm; |
4435
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
4436
|
|
|
|
|
|
|
4437
|
366
|
|
|
|
|
POPBLOCK(cx,newpm); |
4438
|
|
|
|
|
|
assert(CxTYPE(cx) == CXt_GIVEN); |
4439
|
|
|
|
|
|
|
4440
|
366
|
|
|
|
|
TAINT_NOT; |
4441
|
366
|
|
|
|
|
SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); |
4442
|
366
|
|
|
|
|
PL_curpm = newpm; /* Don't pop $1 et al till now */ |
4443
|
|
|
|
|
|
|
4444
|
366
|
|
|
|
|
LEAVE_with_name("given"); |
4445
|
366
|
|
|
|
|
RETURN; |
4446
|
|
|
|
|
|
} |
4447
|
|
|
|
|
|
|
4448
|
|
|
|
|
|
/* Helper routines used by pp_smartmatch */ |
4449
|
|
|
|
|
|
STATIC PMOP * |
4450
|
94
|
|
|
|
|
S_make_matcher(pTHX_ REGEXP *re) |
4451
|
|
|
|
|
|
{ |
4452
|
|
|
|
|
|
dVAR; |
4453
|
94
|
|
|
|
|
PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); |
4454
|
|
|
|
|
|
|
4455
|
|
|
|
|
|
PERL_ARGS_ASSERT_MAKE_MATCHER; |
4456
|
|
|
|
|
|
|
4457
|
94
|
|
|
|
|
PM_SETRE(matcher, ReREFCNT_inc(re)); |
4458
|
|
|
|
|
|
|
4459
|
94
|
|
|
|
|
SAVEFREEOP((OP *) matcher); |
4460
|
94
|
|
|
|
|
ENTER_with_name("matcher"); SAVETMPS; |
4461
|
94
|
|
|
|
|
SAVEOP(); |
4462
|
94
|
|
|
|
|
return matcher; |
4463
|
|
|
|
|
|
} |
4464
|
|
|
|
|
|
|
4465
|
|
|
|
|
|
STATIC bool |
4466
|
348
|
|
|
|
|
S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) |
4467
|
|
|
|
|
|
{ |
4468
|
|
|
|
|
|
dVAR; |
4469
|
348
|
|
|
|
|
dSP; |
4470
|
|
|
|
|
|
|
4471
|
|
|
|
|
|
PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; |
4472
|
|
|
|
|
|
|
4473
|
348
|
|
|
|
|
PL_op = (OP *) matcher; |
4474
|
348
|
50
|
|
|
|
XPUSHs(sv); |
4475
|
348
|
|
|
|
|
PUTBACK; |
4476
|
348
|
|
|
|
|
(void) Perl_pp_match(aTHX); |
4477
|
348
|
|
|
|
|
SPAGAIN; |
4478
|
348
|
50
|
|
|
|
return (SvTRUEx(POPs)); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4479
|
|
|
|
|
|
} |
4480
|
|
|
|
|
|
|
4481
|
|
|
|
|
|
STATIC void |
4482
|
94
|
|
|
|
|
S_destroy_matcher(pTHX_ PMOP *matcher) |
4483
|
|
|
|
|
|
{ |
4484
|
|
|
|
|
|
dVAR; |
4485
|
|
|
|
|
|
|
4486
|
|
|
|
|
|
PERL_ARGS_ASSERT_DESTROY_MATCHER; |
4487
|
|
|
|
|
|
PERL_UNUSED_ARG(matcher); |
4488
|
|
|
|
|
|
|
4489
|
94
|
100
|
|
|
|
FREETMPS; |
4490
|
94
|
|
|
|
|
LEAVE_with_name("matcher"); |
4491
|
94
|
|
|
|
|
} |
4492
|
|
|
|
|
|
|
4493
|
|
|
|
|
|
/* Do a smart match */ |
4494
|
1350
|
|
|
|
|
PP(pp_smartmatch) |
4495
|
|
|
|
|
|
{ |
4496
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); |
4497
|
1350
|
|
|
|
|
return do_smartmatch(NULL, NULL, 0); |
4498
|
|
|
|
|
|
} |
4499
|
|
|
|
|
|
|
4500
|
|
|
|
|
|
/* This version of do_smartmatch() implements the |
4501
|
|
|
|
|
|
* table of smart matches that is found in perlsyn. |
4502
|
|
|
|
|
|
*/ |
4503
|
|
|
|
|
|
STATIC OP * |
4504
|
1866
|
|
|
|
|
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) |
4505
|
|
|
|
|
|
{ |
4506
|
|
|
|
|
|
dVAR; |
4507
|
1866
|
|
|
|
|
dSP; |
4508
|
|
|
|
|
|
|
4509
|
|
|
|
|
|
bool object_on_left = FALSE; |
4510
|
1866
|
|
|
|
|
SV *e = TOPs; /* e is for 'expression' */ |
4511
|
1866
|
|
|
|
|
SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ |
4512
|
|
|
|
|
|
|
4513
|
|
|
|
|
|
/* Take care only to invoke mg_get() once for each argument. |
4514
|
|
|
|
|
|
* Currently we do this by copying the SV if it's magical. */ |
4515
|
1866
|
50
|
|
|
|
if (d) { |
4516
|
1866
|
100
|
|
|
|
if (!copied && SvGMAGICAL(d)) |
|
|
100
|
|
|
|
|
4517
|
88
|
|
|
|
|
d = sv_mortalcopy(d); |
4518
|
|
|
|
|
|
} |
4519
|
|
|
|
|
|
else |
4520
|
|
|
|
|
|
d = &PL_sv_undef; |
4521
|
|
|
|
|
|
|
4522
|
|
|
|
|
|
assert(e); |
4523
|
1866
|
100
|
|
|
|
if (SvGMAGICAL(e)) |
4524
|
86
|
|
|
|
|
e = sv_mortalcopy(e); |
4525
|
|
|
|
|
|
|
4526
|
|
|
|
|
|
/* First of all, handle overload magic of the rightmost argument */ |
4527
|
1866
|
100
|
|
|
|
if (SvAMAGIC(e)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4528
|
|
|
|
|
|
SV * tmpsv; |
4529
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); |
4530
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); |
4531
|
|
|
|
|
|
|
4532
|
52
|
|
|
|
|
tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); |
4533
|
52
|
100
|
|
|
|
if (tmpsv) { |
4534
|
24
|
|
|
|
|
SPAGAIN; |
4535
|
24
|
|
|
|
|
(void)POPs; |
4536
|
24
|
|
|
|
|
SETs(tmpsv); |
4537
|
24
|
|
|
|
|
RETURN; |
4538
|
|
|
|
|
|
} |
4539
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); |
4540
|
|
|
|
|
|
} |
4541
|
|
|
|
|
|
|
4542
|
1842
|
|
|
|
|
SP -= 2; /* Pop the values */ |
4543
|
|
|
|
|
|
|
4544
|
|
|
|
|
|
|
4545
|
|
|
|
|
|
/* ~~ undef */ |
4546
|
1842
|
100
|
|
|
|
if (!SvOK(e)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4547
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); |
4548
|
134
|
100
|
|
|
|
if (SvOK(d)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4549
|
92
|
|
|
|
|
RETPUSHNO; |
4550
|
|
|
|
|
|
else |
4551
|
42
|
|
|
|
|
RETPUSHYES; |
4552
|
|
|
|
|
|
} |
4553
|
|
|
|
|
|
|
4554
|
1708
|
100
|
|
|
|
if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { |
|
|
100
|
|
|
|
|
4555
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); |
4556
|
58
|
|
|
|
|
Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); |
4557
|
|
|
|
|
|
} |
4558
|
1650
|
100
|
|
|
|
if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) |
|
|
100
|
|
|
|
|
4559
|
|
|
|
|
|
object_on_left = TRUE; |
4560
|
|
|
|
|
|
|
4561
|
|
|
|
|
|
/* ~~ sub */ |
4562
|
1650
|
100
|
|
|
|
if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { |
|
|
100
|
|
|
|
|
4563
|
|
|
|
|
|
I32 c; |
4564
|
118
|
100
|
|
|
|
if (object_on_left) { |
4565
|
|
|
|
|
|
goto sm_any_sub; /* Treat objects like scalars */ |
4566
|
|
|
|
|
|
} |
4567
|
108
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { |
|
|
100
|
|
|
|
|
4568
|
|
|
|
|
|
/* Test sub truth for each key */ |
4569
|
|
|
|
|
|
HE *he; |
4570
|
|
|
|
|
|
bool andedresults = TRUE; |
4571
|
28
|
|
|
|
|
HV *hv = (HV*) SvRV(d); |
4572
|
28
|
|
|
|
|
I32 numkeys = hv_iterinit(hv); |
4573
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); |
4574
|
28
|
100
|
|
|
|
if (numkeys == 0) |
4575
|
8
|
|
|
|
|
RETPUSHYES; |
4576
|
66
|
100
|
|
|
|
while ( (he = hv_iternext(hv)) ) { |
4577
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); |
4578
|
48
|
|
|
|
|
ENTER_with_name("smartmatch_hash_key_test"); |
4579
|
48
|
|
|
|
|
SAVETMPS; |
4580
|
48
|
50
|
|
|
|
PUSHMARK(SP); |
4581
|
48
|
|
|
|
|
PUSHs(hv_iterkeysv(he)); |
4582
|
48
|
|
|
|
|
PUTBACK; |
4583
|
48
|
|
|
|
|
c = call_sv(e, G_SCALAR); |
4584
|
46
|
|
|
|
|
SPAGAIN; |
4585
|
46
|
50
|
|
|
|
if (c == 0) |
4586
|
|
|
|
|
|
andedresults = FALSE; |
4587
|
|
|
|
|
|
else |
4588
|
46
|
50
|
|
|
|
andedresults = SvTRUEx(POPs) && andedresults; |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4589
|
46
|
50
|
|
|
|
FREETMPS; |
4590
|
46
|
|
|
|
|
LEAVE_with_name("smartmatch_hash_key_test"); |
4591
|
|
|
|
|
|
} |
4592
|
18
|
100
|
|
|
|
if (andedresults) |
4593
|
10
|
|
|
|
|
RETPUSHYES; |
4594
|
|
|
|
|
|
else |
4595
|
8
|
|
|
|
|
RETPUSHNO; |
4596
|
|
|
|
|
|
} |
4597
|
80
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { |
|
|
100
|
|
|
|
|
4598
|
|
|
|
|
|
/* Test sub truth for each element */ |
4599
|
|
|
|
|
|
SSize_t i; |
4600
|
|
|
|
|
|
bool andedresults = TRUE; |
4601
|
28
|
|
|
|
|
AV *av = (AV*) SvRV(d); |
4602
|
28
|
|
|
|
|
const I32 len = av_len(av); |
4603
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); |
4604
|
28
|
100
|
|
|
|
if (len == -1) |
4605
|
8
|
|
|
|
|
RETPUSHYES; |
4606
|
56
|
100
|
|
|
|
for (i = 0; i <= len; ++i) { |
4607
|
48
|
|
|
|
|
SV * const * const svp = av_fetch(av, i, FALSE); |
4608
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); |
4609
|
48
|
|
|
|
|
ENTER_with_name("smartmatch_array_elem_test"); |
4610
|
48
|
|
|
|
|
SAVETMPS; |
4611
|
48
|
50
|
|
|
|
PUSHMARK(SP); |
4612
|
48
|
50
|
|
|
|
if (svp) |
4613
|
48
|
|
|
|
|
PUSHs(*svp); |
4614
|
48
|
|
|
|
|
PUTBACK; |
4615
|
48
|
|
|
|
|
c = call_sv(e, G_SCALAR); |
4616
|
46
|
|
|
|
|
SPAGAIN; |
4617
|
46
|
50
|
|
|
|
if (c == 0) |
4618
|
|
|
|
|
|
andedresults = FALSE; |
4619
|
|
|
|
|
|
else |
4620
|
46
|
50
|
|
|
|
andedresults = SvTRUEx(POPs) && andedresults; |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4621
|
46
|
100
|
|
|
|
FREETMPS; |
4622
|
46
|
|
|
|
|
LEAVE_with_name("smartmatch_array_elem_test"); |
4623
|
|
|
|
|
|
} |
4624
|
18
|
100
|
|
|
|
if (andedresults) |
4625
|
10
|
|
|
|
|
RETPUSHYES; |
4626
|
|
|
|
|
|
else |
4627
|
8
|
|
|
|
|
RETPUSHNO; |
4628
|
|
|
|
|
|
} |
4629
|
|
|
|
|
|
else { |
4630
|
|
|
|
|
|
sm_any_sub: |
4631
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); |
4632
|
62
|
|
|
|
|
ENTER_with_name("smartmatch_coderef"); |
4633
|
62
|
|
|
|
|
SAVETMPS; |
4634
|
62
|
50
|
|
|
|
PUSHMARK(SP); |
4635
|
62
|
|
|
|
|
PUSHs(d); |
4636
|
62
|
|
|
|
|
PUTBACK; |
4637
|
62
|
|
|
|
|
c = call_sv(e, G_SCALAR); |
4638
|
50
|
|
|
|
|
SPAGAIN; |
4639
|
50
|
50
|
|
|
|
if (c == 0) |
4640
|
0
|
|
|
|
|
PUSHs(&PL_sv_no); |
4641
|
50
|
100
|
|
|
|
else if (SvTEMP(TOPs)) |
4642
|
44
|
|
|
|
|
SvREFCNT_inc_void(TOPs); |
4643
|
50
|
100
|
|
|
|
FREETMPS; |
4644
|
50
|
|
|
|
|
LEAVE_with_name("smartmatch_coderef"); |
4645
|
50
|
|
|
|
|
RETURN; |
4646
|
|
|
|
|
|
} |
4647
|
|
|
|
|
|
} |
4648
|
|
|
|
|
|
/* ~~ %hash */ |
4649
|
1532
|
100
|
|
|
|
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { |
|
|
100
|
|
|
|
|
4650
|
170
|
100
|
|
|
|
if (object_on_left) { |
4651
|
|
|
|
|
|
goto sm_any_hash; /* Treat objects like scalars */ |
4652
|
|
|
|
|
|
} |
4653
|
168
|
100
|
|
|
|
else if (!SvOK(d)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4654
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); |
4655
|
8
|
|
|
|
|
RETPUSHNO; |
4656
|
|
|
|
|
|
} |
4657
|
160
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { |
|
|
100
|
|
|
|
|
4658
|
|
|
|
|
|
/* Check that the key-sets are identical */ |
4659
|
|
|
|
|
|
HE *he; |
4660
|
52
|
|
|
|
|
HV *other_hv = MUTABLE_HV(SvRV(d)); |
4661
|
|
|
|
|
|
bool tied = FALSE; |
4662
|
|
|
|
|
|
bool other_tied = FALSE; |
4663
|
|
|
|
|
|
U32 this_key_count = 0, |
4664
|
|
|
|
|
|
other_key_count = 0; |
4665
|
52
|
|
|
|
|
HV *hv = MUTABLE_HV(SvRV(e)); |
4666
|
|
|
|
|
|
|
4667
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); |
4668
|
|
|
|
|
|
/* Tied hashes don't know how many keys they have. */ |
4669
|
52
|
100
|
|
|
|
if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { |
|
|
50
|
|
|
|
|
4670
|
|
|
|
|
|
tied = TRUE; |
4671
|
|
|
|
|
|
} |
4672
|
34
|
100
|
|
|
|
else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { |
|
|
50
|
|
|
|
|
4673
|
|
|
|
|
|
HV * const temp = other_hv; |
4674
|
|
|
|
|
|
other_hv = hv; |
4675
|
|
|
|
|
|
hv = temp; |
4676
|
|
|
|
|
|
tied = TRUE; |
4677
|
|
|
|
|
|
} |
4678
|
52
|
100
|
|
|
|
if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) |
|
|
50
|
|
|
|
|
4679
|
|
|
|
|
|
other_tied = TRUE; |
4680
|
|
|
|
|
|
|
4681
|
52
|
100
|
|
|
|
if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4682
|
6
|
|
|
|
|
RETPUSHNO; |
4683
|
|
|
|
|
|
|
4684
|
|
|
|
|
|
/* The hashes have the same number of keys, so it suffices |
4685
|
|
|
|
|
|
to check that one is a subset of the other. */ |
4686
|
46
|
|
|
|
|
(void) hv_iterinit(hv); |
4687
|
359
|
100
|
|
|
|
while ( (he = hv_iternext(hv)) ) { |
4688
|
638
|
|
|
|
|
SV *key = hv_iterkeysv(he); |
4689
|
|
|
|
|
|
|
4690
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); |
4691
|
638
|
|
|
|
|
++ this_key_count; |
4692
|
|
|
|
|
|
|
4693
|
638
|
100
|
|
|
|
if(!hv_exists_ent(other_hv, key, 0)) { |
4694
|
12
|
|
|
|
|
(void) hv_iterinit(hv); /* reset iterator */ |
4695
|
12
|
|
|
|
|
RETPUSHNO; |
4696
|
|
|
|
|
|
} |
4697
|
|
|
|
|
|
} |
4698
|
|
|
|
|
|
|
4699
|
34
|
100
|
|
|
|
if (other_tied) { |
4700
|
8
|
|
|
|
|
(void) hv_iterinit(other_hv); |
4701
|
26
|
100
|
|
|
|
while ( hv_iternext(other_hv) ) |
4702
|
14
|
|
|
|
|
++other_key_count; |
4703
|
|
|
|
|
|
} |
4704
|
|
|
|
|
|
else |
4705
|
26
|
50
|
|
|
|
other_key_count = HvUSEDKEYS(other_hv); |
4706
|
|
|
|
|
|
|
4707
|
34
|
50
|
|
|
|
if (this_key_count != other_key_count) |
4708
|
0
|
|
|
|
|
RETPUSHNO; |
4709
|
|
|
|
|
|
else |
4710
|
34
|
|
|
|
|
RETPUSHYES; |
4711
|
|
|
|
|
|
} |
4712
|
108
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { |
|
|
100
|
|
|
|
|
4713
|
50
|
|
|
|
|
AV * const other_av = MUTABLE_AV(SvRV(d)); |
4714
|
50
|
|
|
|
|
const SSize_t other_len = av_len(other_av) + 1; |
4715
|
|
|
|
|
|
SSize_t i; |
4716
|
50
|
|
|
|
|
HV *hv = MUTABLE_HV(SvRV(e)); |
4717
|
|
|
|
|
|
|
4718
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); |
4719
|
82
|
100
|
|
|
|
for (i = 0; i < other_len; ++i) { |
4720
|
66
|
|
|
|
|
SV ** const svp = av_fetch(other_av, i, FALSE); |
4721
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); |
4722
|
66
|
50
|
|
|
|
if (svp) { /* ??? When can this not happen? */ |
4723
|
66
|
100
|
|
|
|
if (hv_exists_ent(hv, *svp, 0)) |
4724
|
34
|
|
|
|
|
RETPUSHYES; |
4725
|
|
|
|
|
|
} |
4726
|
|
|
|
|
|
} |
4727
|
16
|
|
|
|
|
RETPUSHNO; |
4728
|
|
|
|
|
|
} |
4729
|
58
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { |
|
|
50
|
|
|
|
|
4730
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); |
4731
|
|
|
|
|
|
sm_regex_hash: |
4732
|
|
|
|
|
|
{ |
4733
|
38
|
|
|
|
|
PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); |
4734
|
|
|
|
|
|
HE *he; |
4735
|
38
|
|
|
|
|
HV *hv = MUTABLE_HV(SvRV(e)); |
4736
|
|
|
|
|
|
|
4737
|
38
|
|
|
|
|
(void) hv_iterinit(hv); |
4738
|
143
|
100
|
|
|
|
while ( (he = hv_iternext(hv)) ) { |
4739
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); |
4740
|
236
|
100
|
|
|
|
if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { |
4741
|
26
|
|
|
|
|
(void) hv_iterinit(hv); |
4742
|
26
|
|
|
|
|
destroy_matcher(matcher); |
4743
|
26
|
|
|
|
|
RETPUSHYES; |
4744
|
|
|
|
|
|
} |
4745
|
|
|
|
|
|
} |
4746
|
12
|
|
|
|
|
destroy_matcher(matcher); |
4747
|
12
|
|
|
|
|
RETPUSHNO; |
4748
|
|
|
|
|
|
} |
4749
|
|
|
|
|
|
} |
4750
|
|
|
|
|
|
else { |
4751
|
|
|
|
|
|
sm_any_hash: |
4752
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); |
4753
|
40
|
100
|
|
|
|
if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) |
4754
|
22
|
|
|
|
|
RETPUSHYES; |
4755
|
|
|
|
|
|
else |
4756
|
18
|
|
|
|
|
RETPUSHNO; |
4757
|
|
|
|
|
|
} |
4758
|
|
|
|
|
|
} |
4759
|
|
|
|
|
|
/* ~~ @array */ |
4760
|
1362
|
100
|
|
|
|
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { |
|
|
100
|
|
|
|
|
4761
|
264
|
100
|
|
|
|
if (object_on_left) { |
4762
|
|
|
|
|
|
goto sm_any_array; /* Treat objects like scalars */ |
4763
|
|
|
|
|
|
} |
4764
|
260
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { |
|
|
100
|
|
|
|
|
4765
|
36
|
|
|
|
|
AV * const other_av = MUTABLE_AV(SvRV(e)); |
4766
|
36
|
|
|
|
|
const SSize_t other_len = av_len(other_av) + 1; |
4767
|
|
|
|
|
|
SSize_t i; |
4768
|
|
|
|
|
|
|
4769
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); |
4770
|
40
|
100
|
|
|
|
for (i = 0; i < other_len; ++i) { |
4771
|
30
|
|
|
|
|
SV ** const svp = av_fetch(other_av, i, FALSE); |
4772
|
|
|
|
|
|
|
4773
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); |
4774
|
30
|
50
|
|
|
|
if (svp) { /* ??? When can this not happen? */ |
4775
|
30
|
100
|
|
|
|
if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) |
4776
|
26
|
|
|
|
|
RETPUSHYES; |
4777
|
|
|
|
|
|
} |
4778
|
|
|
|
|
|
} |
4779
|
10
|
|
|
|
|
RETPUSHNO; |
4780
|
|
|
|
|
|
} |
4781
|
224
|
100
|
|
|
|
if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { |
|
|
100
|
|
|
|
|
4782
|
84
|
|
|
|
|
AV *other_av = MUTABLE_AV(SvRV(d)); |
4783
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); |
4784
|
84
|
100
|
|
|
|
if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) |
4785
|
6
|
|
|
|
|
RETPUSHNO; |
4786
|
|
|
|
|
|
else { |
4787
|
|
|
|
|
|
SSize_t i; |
4788
|
78
|
|
|
|
|
const SSize_t other_len = av_len(other_av); |
4789
|
|
|
|
|
|
|
4790
|
78
|
100
|
|
|
|
if (NULL == seen_this) { |
4791
|
72
|
|
|
|
|
seen_this = newHV(); |
4792
|
72
|
|
|
|
|
(void) sv_2mortal(MUTABLE_SV(seen_this)); |
4793
|
|
|
|
|
|
} |
4794
|
78
|
100
|
|
|
|
if (NULL == seen_other) { |
4795
|
72
|
|
|
|
|
seen_other = newHV(); |
4796
|
72
|
|
|
|
|
(void) sv_2mortal(MUTABLE_SV(seen_other)); |
4797
|
|
|
|
|
|
} |
4798
|
356
|
100
|
|
|
|
for(i = 0; i <= other_len; ++i) { |
4799
|
294
|
|
|
|
|
SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); |
4800
|
294
|
|
|
|
|
SV * const * const other_elem = av_fetch(other_av, i, FALSE); |
4801
|
|
|
|
|
|
|
4802
|
294
|
50
|
|
|
|
if (!this_elem || !other_elem) { |
4803
|
0
|
0
|
|
|
|
if ((this_elem && SvOK(*this_elem)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4804
|
0
|
0
|
|
|
|
|| (other_elem && SvOK(*other_elem))) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4805
|
0
|
|
|
|
|
RETPUSHNO; |
4806
|
|
|
|
|
|
} |
4807
|
294
|
100
|
|
|
|
else if (hv_exists_ent(seen_this, |
4808
|
288
|
50
|
|
|
|
sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || |
4809
|
288
|
|
|
|
|
hv_exists_ent(seen_other, |
4810
|
|
|
|
|
|
sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) |
4811
|
|
|
|
|
|
{ |
4812
|
6
|
100
|
|
|
|
if (*this_elem != *other_elem) |
4813
|
2
|
|
|
|
|
RETPUSHNO; |
4814
|
|
|
|
|
|
} |
4815
|
|
|
|
|
|
else { |
4816
|
288
|
|
|
|
|
(void)hv_store_ent(seen_this, |
4817
|
|
|
|
|
|
sv_2mortal(newSViv(PTR2IV(*this_elem))), |
4818
|
|
|
|
|
|
&PL_sv_undef, 0); |
4819
|
288
|
|
|
|
|
(void)hv_store_ent(seen_other, |
4820
|
|
|
|
|
|
sv_2mortal(newSViv(PTR2IV(*other_elem))), |
4821
|
|
|
|
|
|
&PL_sv_undef, 0); |
4822
|
288
|
|
|
|
|
PUSHs(*other_elem); |
4823
|
288
|
|
|
|
|
PUSHs(*this_elem); |
4824
|
|
|
|
|
|
|
4825
|
288
|
|
|
|
|
PUTBACK; |
4826
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); |
4827
|
288
|
|
|
|
|
(void) do_smartmatch(seen_this, seen_other, 0); |
4828
|
288
|
|
|
|
|
SPAGAIN; |
4829
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); |
4830
|
|
|
|
|
|
|
4831
|
288
|
50
|
|
|
|
if (!SvTRUEx(POPs)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
4832
|
14
|
|
|
|
|
RETPUSHNO; |
4833
|
|
|
|
|
|
} |
4834
|
|
|
|
|
|
} |
4835
|
62
|
|
|
|
|
RETPUSHYES; |
4836
|
|
|
|
|
|
} |
4837
|
|
|
|
|
|
} |
4838
|
140
|
100
|
|
|
|
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { |
|
|
50
|
|
|
|
|
4839
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); |
4840
|
|
|
|
|
|
sm_regex_array: |
4841
|
|
|
|
|
|
{ |
4842
|
30
|
|
|
|
|
PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); |
4843
|
30
|
|
|
|
|
const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e))); |
4844
|
|
|
|
|
|
SSize_t i; |
4845
|
|
|
|
|
|
|
4846
|
100
|
100
|
|
|
|
for(i = 0; i <= this_len; ++i) { |
4847
|
86
|
|
|
|
|
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); |
4848
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); |
4849
|
86
|
50
|
|
|
|
if (svp && matcher_matches_sv(matcher, *svp)) { |
|
|
100
|
|
|
|
|
4850
|
16
|
|
|
|
|
destroy_matcher(matcher); |
4851
|
16
|
|
|
|
|
RETPUSHYES; |
4852
|
|
|
|
|
|
} |
4853
|
|
|
|
|
|
} |
4854
|
14
|
|
|
|
|
destroy_matcher(matcher); |
4855
|
14
|
|
|
|
|
RETPUSHNO; |
4856
|
|
|
|
|
|
} |
4857
|
|
|
|
|
|
} |
4858
|
128
|
100
|
|
|
|
else if (!SvOK(d)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4859
|
|
|
|
|
|
/* undef ~~ array */ |
4860
|
18
|
|
|
|
|
const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e))); |
4861
|
|
|
|
|
|
SSize_t i; |
4862
|
|
|
|
|
|
|
4863
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); |
4864
|
40
|
100
|
|
|
|
for (i = 0; i <= this_len; ++i) { |
4865
|
30
|
|
|
|
|
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); |
4866
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); |
4867
|
30
|
100
|
|
|
|
if (!svp || !SvOK(*svp)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4868
|
8
|
|
|
|
|
RETPUSHYES; |
4869
|
|
|
|
|
|
} |
4870
|
10
|
|
|
|
|
RETPUSHNO; |
4871
|
|
|
|
|
|
} |
4872
|
|
|
|
|
|
else { |
4873
|
|
|
|
|
|
sm_any_array: |
4874
|
|
|
|
|
|
{ |
4875
|
|
|
|
|
|
SSize_t i; |
4876
|
114
|
|
|
|
|
const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e))); |
4877
|
|
|
|
|
|
|
4878
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); |
4879
|
276
|
100
|
|
|
|
for (i = 0; i <= this_len; ++i) { |
4880
|
228
|
|
|
|
|
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); |
4881
|
228
|
50
|
|
|
|
if (!svp) |
4882
|
0
|
|
|
|
|
continue; |
4883
|
|
|
|
|
|
|
4884
|
228
|
|
|
|
|
PUSHs(d); |
4885
|
228
|
|
|
|
|
PUSHs(*svp); |
4886
|
228
|
|
|
|
|
PUTBACK; |
4887
|
|
|
|
|
|
/* infinite recursion isn't supposed to happen here */ |
4888
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); |
4889
|
228
|
|
|
|
|
(void) do_smartmatch(NULL, NULL, 1); |
4890
|
228
|
|
|
|
|
SPAGAIN; |
4891
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); |
4892
|
228
|
50
|
|
|
|
if (SvTRUEx(POPs)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
4893
|
66
|
|
|
|
|
RETPUSHYES; |
4894
|
|
|
|
|
|
} |
4895
|
48
|
|
|
|
|
RETPUSHNO; |
4896
|
|
|
|
|
|
} |
4897
|
|
|
|
|
|
} |
4898
|
|
|
|
|
|
} |
4899
|
|
|
|
|
|
/* ~~ qr// */ |
4900
|
1098
|
100
|
|
|
|
else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { |
|
|
100
|
|
|
|
|
4901
|
62
|
100
|
|
|
|
if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4902
|
|
|
|
|
|
SV *t = d; d = e; e = t; |
4903
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); |
4904
|
|
|
|
|
|
goto sm_regex_hash; |
4905
|
|
|
|
|
|
} |
4906
|
44
|
100
|
|
|
|
else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4907
|
|
|
|
|
|
SV *t = d; d = e; e = t; |
4908
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); |
4909
|
|
|
|
|
|
goto sm_regex_array; |
4910
|
|
|
|
|
|
} |
4911
|
|
|
|
|
|
else { |
4912
|
26
|
|
|
|
|
PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); |
4913
|
|
|
|
|
|
|
4914
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); |
4915
|
26
|
|
|
|
|
PUTBACK; |
4916
|
26
|
100
|
|
|
|
PUSHs(matcher_matches_sv(matcher, d) |
4917
|
|
|
|
|
|
? &PL_sv_yes |
4918
|
|
|
|
|
|
: &PL_sv_no); |
4919
|
26
|
|
|
|
|
destroy_matcher(matcher); |
4920
|
26
|
|
|
|
|
RETURN; |
4921
|
|
|
|
|
|
} |
4922
|
|
|
|
|
|
} |
4923
|
|
|
|
|
|
/* ~~ scalar */ |
4924
|
|
|
|
|
|
/* See if there is overload magic on left */ |
4925
|
1036
|
100
|
|
|
|
else if (object_on_left && SvAMAGIC(d)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4926
|
|
|
|
|
|
SV *tmpsv; |
4927
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); |
4928
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); |
4929
|
28
|
|
|
|
|
PUSHs(d); PUSHs(e); |
4930
|
28
|
|
|
|
|
PUTBACK; |
4931
|
28
|
|
|
|
|
tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); |
4932
|
28
|
100
|
|
|
|
if (tmpsv) { |
4933
|
26
|
|
|
|
|
SPAGAIN; |
4934
|
26
|
|
|
|
|
(void)POPs; |
4935
|
26
|
|
|
|
|
SETs(tmpsv); |
4936
|
26
|
|
|
|
|
RETURN; |
4937
|
|
|
|
|
|
} |
4938
|
2
|
|
|
|
|
SP -= 2; |
4939
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); |
4940
|
2
|
|
|
|
|
goto sm_any_scalar; |
4941
|
|
|
|
|
|
} |
4942
|
1008
|
100
|
|
|
|
else if (!SvOK(d)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4943
|
|
|
|
|
|
/* undef ~~ scalar ; we already know that the scalar is SvOK */ |
4944
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); |
4945
|
22
|
|
|
|
|
RETPUSHNO; |
4946
|
|
|
|
|
|
} |
4947
|
|
|
|
|
|
else |
4948
|
|
|
|
|
|
sm_any_scalar: |
4949
|
988
|
100
|
|
|
|
if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4950
|
|
|
|
|
|
DEBUG_M(if (SvNIOK(e)) |
4951
|
|
|
|
|
|
Perl_deb(aTHX_ " applying rule Any-Num\n"); |
4952
|
|
|
|
|
|
else |
4953
|
|
|
|
|
|
Perl_deb(aTHX_ " applying rule Num-numish\n"); |
4954
|
|
|
|
|
|
); |
4955
|
|
|
|
|
|
/* numeric comparison */ |
4956
|
790
|
|
|
|
|
PUSHs(d); PUSHs(e); |
4957
|
790
|
|
|
|
|
PUTBACK; |
4958
|
790
|
100
|
|
|
|
if (CopHINTS_get(PL_curcop) & HINT_INTEGER) |
4959
|
4
|
|
|
|
|
(void) Perl_pp_i_eq(aTHX); |
4960
|
|
|
|
|
|
else |
4961
|
786
|
|
|
|
|
(void) Perl_pp_eq(aTHX); |
4962
|
790
|
|
|
|
|
SPAGAIN; |
4963
|
790
|
50
|
|
|
|
if (SvTRUEx(POPs)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
4964
|
420
|
|
|
|
|
RETPUSHYES; |
4965
|
|
|
|
|
|
else |
4966
|
370
|
|
|
|
|
RETPUSHNO; |
4967
|
|
|
|
|
|
} |
4968
|
|
|
|
|
|
|
4969
|
|
|
|
|
|
/* As a last resort, use string comparison */ |
4970
|
|
|
|
|
|
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); |
4971
|
198
|
|
|
|
|
PUSHs(d); PUSHs(e); |
4972
|
198
|
|
|
|
|
PUTBACK; |
4973
|
995
|
|
|
|
|
return Perl_pp_seq(aTHX); |
4974
|
|
|
|
|
|
} |
4975
|
|
|
|
|
|
|
4976
|
848
|
|
|
|
|
PP(pp_enterwhen) |
4977
|
|
|
|
|
|
{ |
4978
|
848
|
|
|
|
|
dVAR; dSP; |
4979
|
|
|
|
|
|
PERL_CONTEXT *cx; |
4980
|
848
|
100
|
|
|
|
const I32 gimme = GIMME_V; |
4981
|
|
|
|
|
|
|
4982
|
|
|
|
|
|
/* This is essentially an optimization: if the match |
4983
|
|
|
|
|
|
fails, we don't want to push a context and then |
4984
|
|
|
|
|
|
pop it again right away, so we skip straight |
4985
|
|
|
|
|
|
to the op that follows the leavewhen. |
4986
|
|
|
|
|
|
RETURNOP calls PUTBACK which restores the stack pointer after the POPs. |
4987
|
|
|
|
|
|
*/ |
4988
|
848
|
100
|
|
|
|
if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
4989
|
466
|
|
|
|
|
RETURNOP(cLOGOP->op_other->op_next); |
4990
|
|
|
|
|
|
|
4991
|
382
|
|
|
|
|
ENTER_with_name("when"); |
4992
|
382
|
|
|
|
|
SAVETMPS; |
4993
|
|
|
|
|
|
|
4994
|
382
|
50
|
|
|
|
PUSHBLOCK(cx, CXt_WHEN, SP); |
4995
|
382
|
|
|
|
|
PUSHWHEN(cx); |
4996
|
|
|
|
|
|
|
4997
|
615
|
|
|
|
|
RETURN; |
4998
|
|
|
|
|
|
} |
4999
|
|
|
|
|
|
|
5000
|
284
|
|
|
|
|
PP(pp_leavewhen) |
5001
|
|
|
|
|
|
{ |
5002
|
284
|
|
|
|
|
dVAR; dSP; |
5003
|
|
|
|
|
|
I32 cxix; |
5004
|
|
|
|
|
|
PERL_CONTEXT *cx; |
5005
|
|
|
|
|
|
I32 gimme; |
5006
|
|
|
|
|
|
SV **newsp; |
5007
|
|
|
|
|
|
PMOP *newpm; |
5008
|
|
|
|
|
|
|
5009
|
284
|
|
|
|
|
cxix = dopoptogiven(cxstack_ix); |
5010
|
284
|
100
|
|
|
|
if (cxix < 0) |
5011
|
|
|
|
|
|
/* diag_listed_as: Can't "when" outside a topicalizer */ |
5012
|
4
|
100
|
|
|
|
DIE(aTHX_ "Can't \"%s\" outside a topicalizer", |
5013
|
4
|
|
|
|
|
PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); |
5014
|
|
|
|
|
|
|
5015
|
280
|
|
|
|
|
POPBLOCK(cx,newpm); |
5016
|
|
|
|
|
|
assert(CxTYPE(cx) == CXt_WHEN); |
5017
|
|
|
|
|
|
|
5018
|
280
|
|
|
|
|
TAINT_NOT; |
5019
|
280
|
|
|
|
|
SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); |
5020
|
280
|
|
|
|
|
PL_curpm = newpm; /* pop $1 et al */ |
5021
|
|
|
|
|
|
|
5022
|
280
|
|
|
|
|
LEAVE_with_name("when"); |
5023
|
|
|
|
|
|
|
5024
|
280
|
100
|
|
|
|
if (cxix < cxstack_ix) |
5025
|
246
|
|
|
|
|
dounwind(cxix); |
5026
|
|
|
|
|
|
|
5027
|
280
|
|
|
|
|
cx = &cxstack[cxix]; |
5028
|
|
|
|
|
|
|
5029
|
280
|
100
|
|
|
|
if (CxFOREACH(cx)) { |
|
|
50
|
|
|
|
|
5030
|
|
|
|
|
|
/* clear off anything above the scope we're re-entering */ |
5031
|
20
|
|
|
|
|
I32 inner = PL_scopestack_ix; |
5032
|
|
|
|
|
|
|
5033
|
20
|
|
|
|
|
TOPBLOCK(cx); |
5034
|
20
|
50
|
|
|
|
if (PL_scopestack_ix < inner) |
5035
|
0
|
|
|
|
|
leave_scope(PL_scopestack[PL_scopestack_ix]); |
5036
|
20
|
|
|
|
|
PL_curcop = cx->blk_oldcop; |
5037
|
|
|
|
|
|
|
5038
|
20
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
5039
|
20
|
|
|
|
|
return cx->blk_loop.my_op->op_nextop; |
5040
|
|
|
|
|
|
} |
5041
|
|
|
|
|
|
else { |
5042
|
260
|
50
|
|
|
|
PERL_ASYNC_CHECK(); |
5043
|
270
|
|
|
|
|
RETURNOP(cx->blk_givwhen.leave_op); |
5044
|
|
|
|
|
|
} |
5045
|
|
|
|
|
|
} |
5046
|
|
|
|
|
|
|
5047
|
70
|
|
|
|
|
PP(pp_continue) |
5048
|
|
|
|
|
|
{ |
5049
|
|
|
|
|
|
dVAR; dSP; |
5050
|
|
|
|
|
|
I32 cxix; |
5051
|
|
|
|
|
|
PERL_CONTEXT *cx; |
5052
|
|
|
|
|
|
I32 gimme; |
5053
|
|
|
|
|
|
SV **newsp; |
5054
|
|
|
|
|
|
PMOP *newpm; |
5055
|
|
|
|
|
|
|
5056
|
|
|
|
|
|
PERL_UNUSED_VAR(gimme); |
5057
|
|
|
|
|
|
|
5058
|
70
|
|
|
|
|
cxix = dopoptowhen(cxstack_ix); |
5059
|
70
|
100
|
|
|
|
if (cxix < 0) |
5060
|
4
|
|
|
|
|
DIE(aTHX_ "Can't \"continue\" outside a when block"); |
5061
|
|
|
|
|
|
|
5062
|
66
|
50
|
|
|
|
if (cxix < cxstack_ix) |
5063
|
66
|
|
|
|
|
dounwind(cxix); |
5064
|
|
|
|
|
|
|
5065
|
66
|
|
|
|
|
POPBLOCK(cx,newpm); |
5066
|
|
|
|
|
|
assert(CxTYPE(cx) == CXt_WHEN); |
5067
|
|
|
|
|
|
|
5068
|
|
|
|
|
|
SP = newsp; |
5069
|
66
|
|
|
|
|
PL_curpm = newpm; /* pop $1 et al */ |
5070
|
|
|
|
|
|
|
5071
|
66
|
|
|
|
|
LEAVE_with_name("when"); |
5072
|
66
|
|
|
|
|
RETURNOP(cx->blk_givwhen.leave_op->op_next); |
5073
|
|
|
|
|
|
} |
5074
|
|
|
|
|
|
|
5075
|
28
|
|
|
|
|
PP(pp_break) |
5076
|
|
|
|
|
|
{ |
5077
|
|
|
|
|
|
dVAR; |
5078
|
|
|
|
|
|
I32 cxix; |
5079
|
|
|
|
|
|
PERL_CONTEXT *cx; |
5080
|
|
|
|
|
|
|
5081
|
28
|
|
|
|
|
cxix = dopoptogiven(cxstack_ix); |
5082
|
28
|
100
|
|
|
|
if (cxix < 0) |
5083
|
4
|
|
|
|
|
DIE(aTHX_ "Can't \"break\" outside a given block"); |
5084
|
|
|
|
|
|
|
5085
|
24
|
|
|
|
|
cx = &cxstack[cxix]; |
5086
|
24
|
100
|
|
|
|
if (CxFOREACH(cx)) |
|
|
50
|
|
|
|
|
5087
|
10
|
|
|
|
|
DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); |
5088
|
|
|
|
|
|
|
5089
|
14
|
100
|
|
|
|
if (cxix < cxstack_ix) |
5090
|
12
|
|
|
|
|
dounwind(cxix); |
5091
|
|
|
|
|
|
|
5092
|
|
|
|
|
|
/* Restore the sp at the time we entered the given block */ |
5093
|
14
|
|
|
|
|
TOPBLOCK(cx); |
5094
|
|
|
|
|
|
|
5095
|
14
|
|
|
|
|
return cx->blk_givwhen.leave_op; |
5096
|
|
|
|
|
|
} |
5097
|
|
|
|
|
|
|
5098
|
|
|
|
|
|
static MAGIC * |
5099
|
3336
|
|
|
|
|
S_doparseform(pTHX_ SV *sv) |
5100
|
|
|
|
|
|
{ |
5101
|
|
|
|
|
|
STRLEN len; |
5102
|
3336
|
100
|
|
|
|
char *s = SvPV(sv, len); |
5103
|
|
|
|
|
|
char *send; |
5104
|
|
|
|
|
|
char *base = NULL; /* start of current field */ |
5105
|
|
|
|
|
|
I32 skipspaces = 0; /* number of contiguous spaces seen */ |
5106
|
|
|
|
|
|
bool noblank = FALSE; /* ~ or ~~ seen on this line */ |
5107
|
|
|
|
|
|
bool repeat = FALSE; /* ~~ seen on this line */ |
5108
|
|
|
|
|
|
bool postspace = FALSE; /* a text field may need right padding */ |
5109
|
|
|
|
|
|
U32 *fops; |
5110
|
|
|
|
|
|
U32 *fpc; |
5111
|
|
|
|
|
|
U32 *linepc = NULL; /* position of last FF_LINEMARK */ |
5112
|
|
|
|
|
|
I32 arg; |
5113
|
|
|
|
|
|
bool ischop; /* it's a ^ rather than a @ */ |
5114
|
|
|
|
|
|
bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */ |
5115
|
|
|
|
|
|
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ |
5116
|
|
|
|
|
|
MAGIC *mg = NULL; |
5117
|
|
|
|
|
|
SV *sv_copy; |
5118
|
|
|
|
|
|
|
5119
|
|
|
|
|
|
PERL_ARGS_ASSERT_DOPARSEFORM; |
5120
|
|
|
|
|
|
|
5121
|
3336
|
100
|
|
|
|
if (len == 0) |
5122
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Null picture in formline"); |
5123
|
|
|
|
|
|
|
5124
|
3334
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG) { |
5125
|
|
|
|
|
|
/* This might, of course, still return NULL. */ |
5126
|
2956
|
|
|
|
|
mg = mg_find(sv, PERL_MAGIC_fm); |
5127
|
|
|
|
|
|
} else { |
5128
|
378
|
|
|
|
|
sv_upgrade(sv, SVt_PVMG); |
5129
|
|
|
|
|
|
} |
5130
|
|
|
|
|
|
|
5131
|
3334
|
100
|
|
|
|
if (mg) { |
5132
|
|
|
|
|
|
/* still the same as previously-compiled string? */ |
5133
|
1580
|
|
|
|
|
SV *old = mg->mg_obj; |
5134
|
1580
|
50
|
|
|
|
if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) |
5135
|
1580
|
50
|
|
|
|
&& len == SvCUR(old) |
5136
|
1580
|
100
|
|
|
|
&& strnEQ(SvPVX(old), SvPVX(sv), len) |
5137
|
|
|
|
|
|
) { |
5138
|
|
|
|
|
|
DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); |
5139
|
|
|
|
|
|
return mg; |
5140
|
|
|
|
|
|
} |
5141
|
|
|
|
|
|
|
5142
|
|
|
|
|
|
DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); |
5143
|
12
|
|
|
|
|
Safefree(mg->mg_ptr); |
5144
|
12
|
|
|
|
|
mg->mg_ptr = NULL; |
5145
|
12
|
|
|
|
|
SvREFCNT_dec(old); |
5146
|
12
|
|
|
|
|
mg->mg_obj = NULL; |
5147
|
|
|
|
|
|
} |
5148
|
|
|
|
|
|
else { |
5149
|
|
|
|
|
|
DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); |
5150
|
1754
|
|
|
|
|
mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); |
5151
|
|
|
|
|
|
} |
5152
|
|
|
|
|
|
|
5153
|
1766
|
|
|
|
|
sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv)); |
5154
|
1766
|
50
|
|
|
|
s = SvPV(sv_copy, len); /* work on the copy, not the original */ |
5155
|
1766
|
|
|
|
|
send = s + len; |
5156
|
|
|
|
|
|
|
5157
|
|
|
|
|
|
|
5158
|
|
|
|
|
|
/* estimate the buffer size needed */ |
5159
|
283294
|
100
|
|
|
|
for (base = s; s <= send; s++) { |
5160
|
281528
|
100
|
|
|
|
if (*s == '\n' || *s == '@' || *s == '^') |
|
|
100
|
|
|
|
|
5161
|
3894
|
|
|
|
|
maxops += 10; |
5162
|
|
|
|
|
|
} |
5163
|
|
|
|
|
|
s = base; |
5164
|
|
|
|
|
|
base = NULL; |
5165
|
|
|
|
|
|
|
5166
|
1766
|
50
|
|
|
|
Newx(fops, maxops, U32); |
5167
|
|
|
|
|
|
fpc = fops; |
5168
|
|
|
|
|
|
|
5169
|
1766
|
50
|
|
|
|
if (s < send) { |
5170
|
|
|
|
|
|
linepc = fpc; |
5171
|
1766
|
|
|
|
|
*fpc++ = FF_LINEMARK; |
5172
|
|
|
|
|
|
noblank = repeat = FALSE; |
5173
|
|
|
|
|
|
base = s; |
5174
|
|
|
|
|
|
} |
5175
|
|
|
|
|
|
|
5176
|
275508
|
100
|
|
|
|
while (s <= send) { |
5177
|
273742
|
|
|
|
|
switch (*s++) { |
5178
|
|
|
|
|
|
default: |
5179
|
|
|
|
|
|
skipspaces = 0; |
5180
|
266972
|
|
|
|
|
continue; |
5181
|
|
|
|
|
|
|
5182
|
|
|
|
|
|
case '~': |
5183
|
288
|
100
|
|
|
|
if (*s == '~') { |
5184
|
|
|
|
|
|
repeat = TRUE; |
5185
|
160
|
|
|
|
|
skipspaces++; |
5186
|
160
|
|
|
|
|
s++; |
5187
|
|
|
|
|
|
} |
5188
|
|
|
|
|
|
noblank = TRUE; |
5189
|
|
|
|
|
|
/* FALL THROUGH */ |
5190
|
|
|
|
|
|
case ' ': case '\t': |
5191
|
1908
|
|
|
|
|
skipspaces++; |
5192
|
1908
|
|
|
|
|
continue; |
5193
|
|
|
|
|
|
case 0: |
5194
|
968
|
100
|
|
|
|
if (s < send) { |
5195
|
|
|
|
|
|
skipspaces = 0; |
5196
|
8
|
|
|
|
|
continue; |
5197
|
|
|
|
|
|
} /* else FALL THROUGH */ |
5198
|
|
|
|
|
|
case '\n': |
5199
|
1800
|
|
|
|
|
arg = s - base; |
5200
|
1800
|
|
|
|
|
skipspaces++; |
5201
|
1800
|
|
|
|
|
arg -= skipspaces; |
5202
|
1800
|
100
|
|
|
|
if (arg) { |
5203
|
1002
|
100
|
|
|
|
if (postspace) |
5204
|
154
|
|
|
|
|
*fpc++ = FF_SPACE; |
5205
|
1002
|
|
|
|
|
*fpc++ = FF_LITERAL; |
5206
|
1002
|
|
|
|
|
*fpc++ = (U32)arg; |
5207
|
|
|
|
|
|
} |
5208
|
|
|
|
|
|
postspace = FALSE; |
5209
|
1800
|
100
|
|
|
|
if (s <= send) |
5210
|
|
|
|
|
|
skipspaces--; |
5211
|
1800
|
100
|
|
|
|
if (skipspaces) { |
5212
|
1168
|
|
|
|
|
*fpc++ = FF_SKIP; |
5213
|
1168
|
|
|
|
|
*fpc++ = (U32)skipspaces; |
5214
|
|
|
|
|
|
} |
5215
|
|
|
|
|
|
skipspaces = 0; |
5216
|
1800
|
100
|
|
|
|
if (s <= send) |
5217
|
840
|
|
|
|
|
*fpc++ = FF_NEWLINE; |
5218
|
1800
|
100
|
|
|
|
if (noblank) { |
5219
|
288
|
|
|
|
|
*fpc++ = FF_BLANK; |
5220
|
288
|
100
|
|
|
|
if (repeat) |
5221
|
160
|
|
|
|
|
arg = fpc - linepc + 1; |
5222
|
|
|
|
|
|
else |
5223
|
|
|
|
|
|
arg = 0; |
5224
|
288
|
|
|
|
|
*fpc++ = (U32)arg; |
5225
|
|
|
|
|
|
} |
5226
|
1800
|
100
|
|
|
|
if (s < send) { |
5227
|
|
|
|
|
|
linepc = fpc; |
5228
|
34
|
|
|
|
|
*fpc++ = FF_LINEMARK; |
5229
|
|
|
|
|
|
noblank = repeat = FALSE; |
5230
|
|
|
|
|
|
base = s; |
5231
|
|
|
|
|
|
} |
5232
|
|
|
|
|
|
else |
5233
|
1766
|
|
|
|
|
s++; |
5234
|
1800
|
|
|
|
|
continue; |
5235
|
|
|
|
|
|
|
5236
|
|
|
|
|
|
case '@': |
5237
|
|
|
|
|
|
case '^': |
5238
|
3054
|
|
|
|
|
ischop = s[-1] == '^'; |
5239
|
|
|
|
|
|
|
5240
|
3054
|
100
|
|
|
|
if (postspace) { |
5241
|
542
|
|
|
|
|
*fpc++ = FF_SPACE; |
5242
|
|
|
|
|
|
postspace = FALSE; |
5243
|
|
|
|
|
|
} |
5244
|
3054
|
|
|
|
|
arg = (s - base) - 1; |
5245
|
3054
|
100
|
|
|
|
if (arg) { |
5246
|
2154
|
|
|
|
|
*fpc++ = FF_LITERAL; |
5247
|
2154
|
|
|
|
|
*fpc++ = (U32)arg; |
5248
|
|
|
|
|
|
} |
5249
|
|
|
|
|
|
|
5250
|
|
|
|
|
|
base = s - 1; |
5251
|
3054
|
|
|
|
|
*fpc++ = FF_FETCH; |
5252
|
3054
|
100
|
|
|
|
if (*s == '*') { /* @* or ^* */ |
5253
|
1480
|
|
|
|
|
s++; |
5254
|
1480
|
|
|
|
|
*fpc++ = 2; /* skip the @* or ^* */ |
5255
|
1480
|
100
|
|
|
|
if (ischop) { |
5256
|
1086
|
|
|
|
|
*fpc++ = FF_LINESNGL; |
5257
|
1086
|
|
|
|
|
*fpc++ = FF_CHOP; |
5258
|
|
|
|
|
|
} else |
5259
|
394
|
|
|
|
|
*fpc++ = FF_LINEGLOB; |
5260
|
|
|
|
|
|
} |
5261
|
1574
|
100
|
|
|
|
else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
5262
|
84
|
100
|
|
|
|
arg = ischop ? FORM_NUM_BLANK : 0; |
5263
|
|
|
|
|
|
base = s - 1; |
5264
|
386
|
100
|
|
|
|
while (*s == '#') |
5265
|
260
|
|
|
|
|
s++; |
5266
|
84
|
100
|
|
|
|
if (*s == '.') { |
5267
|
44
|
|
|
|
|
const char * const f = ++s; |
5268
|
114
|
100
|
|
|
|
while (*s == '#') |
5269
|
48
|
|
|
|
|
s++; |
5270
|
44
|
|
|
|
|
arg |= FORM_NUM_POINT + (s - f); |
5271
|
|
|
|
|
|
} |
5272
|
84
|
|
|
|
|
*fpc++ = s - base; /* fieldsize for FETCH */ |
5273
|
84
|
|
|
|
|
*fpc++ = FF_DECIMAL; |
5274
|
84
|
|
|
|
|
*fpc++ = (U32)arg; |
5275
|
84
|
|
|
|
|
unchopnum |= ! ischop; |
5276
|
|
|
|
|
|
} |
5277
|
1490
|
100
|
|
|
|
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ |
|
|
100
|
|
|
|
|
5278
|
56
|
100
|
|
|
|
arg = ischop ? FORM_NUM_BLANK : 0; |
5279
|
|
|
|
|
|
base = s - 1; |
5280
|
56
|
|
|
|
|
s++; /* skip the '0' first */ |
5281
|
188
|
100
|
|
|
|
while (*s == '#') |
5282
|
104
|
|
|
|
|
s++; |
5283
|
56
|
100
|
|
|
|
if (*s == '.') { |
5284
|
24
|
|
|
|
|
const char * const f = ++s; |
5285
|
84
|
100
|
|
|
|
while (*s == '#') |
5286
|
48
|
|
|
|
|
s++; |
5287
|
24
|
|
|
|
|
arg |= FORM_NUM_POINT + (s - f); |
5288
|
|
|
|
|
|
} |
5289
|
56
|
|
|
|
|
*fpc++ = s - base; /* fieldsize for FETCH */ |
5290
|
56
|
|
|
|
|
*fpc++ = FF_0DECIMAL; |
5291
|
56
|
|
|
|
|
*fpc++ = (U32)arg; |
5292
|
56
|
|
|
|
|
unchopnum |= ! ischop; |
5293
|
|
|
|
|
|
} |
5294
|
|
|
|
|
|
else { /* text field */ |
5295
|
|
|
|
|
|
I32 prespace = 0; |
5296
|
|
|
|
|
|
bool ismore = FALSE; |
5297
|
|
|
|
|
|
|
5298
|
1434
|
100
|
|
|
|
if (*s == '>') { |
5299
|
1086
|
100
|
|
|
|
while (*++s == '>') ; |
5300
|
|
|
|
|
|
prespace = FF_SPACE; |
5301
|
|
|
|
|
|
} |
5302
|
1136
|
100
|
|
|
|
else if (*s == '|') { |
5303
|
592
|
100
|
|
|
|
while (*++s == '|') ; |
5304
|
|
|
|
|
|
prespace = FF_HALFSPACE; |
5305
|
|
|
|
|
|
postspace = TRUE; |
5306
|
|
|
|
|
|
} |
5307
|
|
|
|
|
|
else { |
5308
|
944
|
100
|
|
|
|
if (*s == '<') |
5309
|
3054
|
100
|
|
|
|
while (*++s == '<') ; |
5310
|
|
|
|
|
|
postspace = TRUE; |
5311
|
|
|
|
|
|
} |
5312
|
1434
|
100
|
|
|
|
if (*s == '.' && s[1] == '.' && s[2] == '.') { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
5313
|
8
|
|
|
|
|
s += 3; |
5314
|
|
|
|
|
|
ismore = TRUE; |
5315
|
|
|
|
|
|
} |
5316
|
1434
|
|
|
|
|
*fpc++ = s - base; /* fieldsize for FETCH */ |
5317
|
|
|
|
|
|
|
5318
|
1434
|
100
|
|
|
|
*fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; |
5319
|
|
|
|
|
|
|
5320
|
1434
|
100
|
|
|
|
if (prespace) |
5321
|
490
|
|
|
|
|
*fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */ |
5322
|
1434
|
|
|
|
|
*fpc++ = FF_ITEM; |
5323
|
1434
|
100
|
|
|
|
if (ismore) |
5324
|
8
|
|
|
|
|
*fpc++ = FF_MORE; |
5325
|
1434
|
100
|
|
|
|
if (ischop) |
5326
|
1084
|
|
|
|
|
*fpc++ = FF_CHOP; |
5327
|
|
|
|
|
|
} |
5328
|
|
|
|
|
|
base = s; |
5329
|
|
|
|
|
|
skipspaces = 0; |
5330
|
138398
|
|
|
|
|
continue; |
5331
|
|
|
|
|
|
} |
5332
|
|
|
|
|
|
} |
5333
|
1766
|
|
|
|
|
*fpc++ = FF_END; |
5334
|
|
|
|
|
|
|
5335
|
|
|
|
|
|
assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ |
5336
|
1766
|
|
|
|
|
arg = fpc - fops; |
5337
|
|
|
|
|
|
|
5338
|
1766
|
|
|
|
|
mg->mg_ptr = (char *) fops; |
5339
|
1766
|
|
|
|
|
mg->mg_len = arg * sizeof(U32); |
5340
|
1766
|
|
|
|
|
mg->mg_obj = sv_copy; |
5341
|
1766
|
|
|
|
|
mg->mg_flags |= MGf_REFCOUNTED; |
5342
|
|
|
|
|
|
|
5343
|
1766
|
100
|
|
|
|
if (unchopnum && repeat) |
|
|
100
|
|
|
|
|
5344
|
1669
|
|
|
|
|
Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)"); |
5345
|
|
|
|
|
|
|
5346
|
|
|
|
|
|
return mg; |
5347
|
|
|
|
|
|
} |
5348
|
|
|
|
|
|
|
5349
|
|
|
|
|
|
|
5350
|
|
|
|
|
|
STATIC bool |
5351
|
|
|
|
|
|
S_num_overflow(NV value, I32 fldsize, I32 frcsize) |
5352
|
|
|
|
|
|
{ |
5353
|
|
|
|
|
|
/* Can value be printed in fldsize chars, using %*.*f ? */ |
5354
|
|
|
|
|
|
NV pwr = 1; |
5355
|
|
|
|
|
|
NV eps = 0.5; |
5356
|
|
|
|
|
|
bool res = FALSE; |
5357
|
128
|
|
|
|
|
int intsize = fldsize - (value < 0 ? 1 : 0); |
5358
|
|
|
|
|
|
|
5359
|
128
|
100
|
|
|
|
if (frcsize & FORM_NUM_POINT) |
5360
|
68
|
|
|
|
|
intsize--; |
5361
|
128
|
|
|
|
|
frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); |
5362
|
128
|
|
|
|
|
intsize -= frcsize; |
5363
|
|
|
|
|
|
|
5364
|
532
|
100
|
|
|
|
while (intsize--) pwr *= 10.0; |
5365
|
160
|
100
|
|
|
|
while (frcsize--) eps /= 10.0; |
5366
|
|
|
|
|
|
|
5367
|
128
|
100
|
|
|
|
if( value >= 0 ){ |
5368
|
104
|
100
|
|
|
|
if (value + eps >= pwr) |
5369
|
|
|
|
|
|
res = TRUE; |
5370
|
|
|
|
|
|
} else { |
5371
|
24
|
100
|
|
|
|
if (value - eps <= -pwr) |
5372
|
|
|
|
|
|
res = TRUE; |
5373
|
|
|
|
|
|
} |
5374
|
|
|
|
|
|
return res; |
5375
|
|
|
|
|
|
} |
5376
|
|
|
|
|
|
|
5377
|
|
|
|
|
|
static I32 |
5378
|
444
|
|
|
|
|
S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) |
5379
|
250
|
100
|
|
|
|
{ |
5380
|
|
|
|
|
|
dVAR; |
5381
|
444
|
50
|
|
|
|
SV * const datasv = FILTER_DATA(idx); |
5382
|
444
|
|
|
|
|
const int filter_has_file = IoLINES(datasv); |
5383
|
444
|
|
|
|
|
SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); |
5384
|
444
|
|
|
|
|
SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); |
5385
|
|
|
|
|
|
int status = 0; |
5386
|
|
|
|
|
|
SV *upstream; |
5387
|
|
|
|
|
|
STRLEN got_len; |
5388
|
|
|
|
|
|
char *got_p = NULL; |
5389
|
|
|
|
|
|
char *prune_from = NULL; |
5390
|
|
|
|
|
|
bool read_from_cache = FALSE; |
5391
|
|
|
|
|
|
STRLEN umaxlen; |
5392
|
|
|
|
|
|
SV *err = NULL; |
5393
|
|
|
|
|
|
|
5394
|
|
|
|
|
|
PERL_ARGS_ASSERT_RUN_USER_FILTER; |
5395
|
|
|
|
|
|
|
5396
|
|
|
|
|
|
assert(maxlen >= 0); |
5397
|
444
|
|
|
|
|
umaxlen = maxlen; |
5398
|
|
|
|
|
|
|
5399
|
|
|
|
|
|
/* I was having segfault trouble under Linux 2.2.5 after a |
5400
|
|
|
|
|
|
parse error occured. (Had to hack around it with a test |
5401
|
|
|
|
|
|
for PL_parser->error_count == 0.) Solaris doesn't segfault -- |
5402
|
|
|
|
|
|
not sure where the trouble is yet. XXX */ |
5403
|
|
|
|
|
|
|
5404
|
|
|
|
|
|
{ |
5405
|
|
|
|
|
|
SV *const cache = datasv; |
5406
|
444
|
100
|
|
|
|
if (SvOK(cache)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
5407
|
|
|
|
|
|
STRLEN cache_len; |
5408
|
230
|
50
|
|
|
|
const char *cache_p = SvPV(cache, cache_len); |
5409
|
|
|
|
|
|
STRLEN take = 0; |
5410
|
|
|
|
|
|
|
5411
|
230
|
100
|
|
|
|
if (umaxlen) { |
5412
|
|
|
|
|
|
/* Running in block mode and we have some cached data already. |
5413
|
|
|
|
|
|
*/ |
5414
|
174
|
100
|
|
|
|
if (cache_len >= umaxlen) { |
5415
|
|
|
|
|
|
/* In fact, so much data we don't even need to call |
5416
|
|
|
|
|
|
filter_read. */ |
5417
|
|
|
|
|
|
take = umaxlen; |
5418
|
|
|
|
|
|
} |
5419
|
|
|
|
|
|
} else { |
5420
|
56
|
|
|
|
|
const char *const first_nl = |
5421
|
56
|
|
|
|
|
(const char *)memchr(cache_p, '\n', cache_len); |
5422
|
56
|
100
|
|
|
|
if (first_nl) { |
5423
|
28
|
|
|
|
|
take = first_nl + 1 - cache_p; |
5424
|
|
|
|
|
|
} |
5425
|
|
|
|
|
|
} |
5426
|
230
|
100
|
|
|
|
if (take) { |
5427
|
194
|
|
|
|
|
sv_catpvn(buf_sv, cache_p, take); |
5428
|
194
|
|
|
|
|
sv_chop(cache, cache_p + take); |
5429
|
|
|
|
|
|
/* Definitely not EOF */ |
5430
|
194
|
|
|
|
|
return 1; |
5431
|
|
|
|
|
|
} |
5432
|
|
|
|
|
|
|
5433
|
36
|
|
|
|
|
sv_catsv(buf_sv, cache); |
5434
|
36
|
100
|
|
|
|
if (umaxlen) { |
5435
|
8
|
|
|
|
|
umaxlen -= cache_len; |
5436
|
|
|
|
|
|
} |
5437
|
36
|
100
|
|
|
|
SvOK_off(cache); |
5438
|
|
|
|
|
|
read_from_cache = TRUE; |
5439
|
|
|
|
|
|
} |
5440
|
|
|
|
|
|
} |
5441
|
|
|
|
|
|
|
5442
|
|
|
|
|
|
/* Filter API says that the filter appends to the contents of the buffer. |
5443
|
|
|
|
|
|
Usually the buffer is "", so the details don't matter. But if it's not, |
5444
|
|
|
|
|
|
then clearly what it contains is already filtered by this filter, so we |
5445
|
|
|
|
|
|
don't want to pass it in a second time. |
5446
|
|
|
|
|
|
I'm going to use a mortal in case the upstream filter croaks. */ |
5447
|
250
|
0
|
|
|
|
upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) |
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5448
|
286
|
50
|
|
|
|
? sv_newmortal() : buf_sv; |
5449
|
161
|
|
|
|
|
SvUPGRADE(upstream, SVt_PV); |
5450
|
|
|
|
|
|
|
5451
|
250
|
100
|
|
|
|
if (filter_has_file) { |
5452
|
148
|
|
|
|
|
status = FILTER_READ(idx+1, upstream, 0); |
5453
|
|
|
|
|
|
} |
5454
|
|
|
|
|
|
|
5455
|
486
|
|
|
|
|
if (filter_sub && status >= 0) { |
5456
|
236
|
|
|
|
|
dSP; |
5457
|
|
|
|
|
|
int count; |
5458
|
|
|
|
|
|
|
5459
|
236
|
|
|
|
|
ENTER_with_name("call_filter_sub"); |
5460
|
236
|
|
|
|
|
SAVE_DEFSV; |
5461
|
236
|
|
|
|
|
SAVETMPS; |
5462
|
118
|
|
|
|
|
EXTEND(SP, 2); |
5463
|
|
|
|
|
|
|
5464
|
354
|
|
|
|
|
DEFSV_set(upstream); |
5465
|
236
|
50
|
|
|
|
PUSHMARK(SP); |
5466
|
236
|
|
|
|
|
mPUSHi(0); |
5467
|
236
|
100
|
|
|
|
if (filter_state) { |
5468
|
124
|
|
|
|
|
PUSHs(filter_state); |
5469
|
|
|
|
|
|
} |
5470
|
236
|
|
|
|
|
PUTBACK; |
5471
|
236
|
|
|
|
|
count = call_sv(filter_sub, G_SCALAR|G_EVAL); |
5472
|
236
|
|
|
|
|
SPAGAIN; |
5473
|
|
|
|
|
|
|
5474
|
354
|
50
|
|
|
|
if (count > 0) { |
|
|
100
|
|
|
|
|
5475
|
236
|
|
|
|
|
SV *out = POPs; |
5476
|
122
|
|
|
|
|
SvGETMAGIC(out); |
5477
|
236
|
100
|
|
|
|
if (SvOK(out)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
5478
|
84
|
100
|
|
|
|
status = SvIV(out); |
5479
|
|
|
|
|
|
} |
5480
|
|
|
|
|
|
else { |
5481
|
152
|
50
|
|
|
|
SV * const errsv = ERRSV; |
5482
|
152
|
50
|
|
|
|
if (SvTRUE_NN(errsv)) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
5483
|
8
|
|
|
|
|
err = newSVsv(errsv); |
5484
|
|
|
|
|
|
} |
5485
|
|
|
|
|
|
} |
5486
|
|
|
|
|
|
|
5487
|
236
|
|
|
|
|
PUTBACK; |
5488
|
236
|
50
|
|
|
|
FREETMPS; |
5489
|
236
|
|
|
|
|
LEAVE_with_name("call_filter_sub"); |
5490
|
|
|
|
|
|
} |
5491
|
|
|
|
|
|
|
5492
|
250
|
100
|
|
|
|
if (SvGMAGICAL(upstream)) { |
5493
|
2
|
|
|
|
|
mg_get(upstream); |
5494
|
2
|
50
|
|
|
|
if (upstream == buf_sv) mg_free(buf_sv); |
5495
|
|
|
|
|
|
} |
5496
|
250
|
100
|
|
|
|
if (SvIsCOW(upstream)) sv_force_normal(upstream); |
5497
|
250
|
100
|
|
|
|
if(!err && SvOK(upstream)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
5498
|
214
|
100
|
|
|
|
got_p = SvPV_nomg(upstream, got_len); |
5499
|
214
|
100
|
|
|
|
if (umaxlen) { |
5500
|
10
|
100
|
|
|
|
if (got_len > umaxlen) { |
5501
|
6
|
|
|
|
|
prune_from = got_p + umaxlen; |
5502
|
|
|
|
|
|
} |
5503
|
|
|
|
|
|
} else { |
5504
|
204
|
|
|
|
|
char *const first_nl = (char *)memchr(got_p, '\n', got_len); |
5505
|
204
|
100
|
|
|
|
if (first_nl && first_nl + 1 < got_p + got_len) { |
|
|
100
|
|
|
|
|
5506
|
|
|
|
|
|
/* There's a second line here... */ |
5507
|
10
|
|
|
|
|
prune_from = first_nl + 1; |
5508
|
|
|
|
|
|
} |
5509
|
|
|
|
|
|
} |
5510
|
|
|
|
|
|
} |
5511
|
250
|
100
|
|
|
|
if (!err && prune_from) { |
5512
|
|
|
|
|
|
/* Oh. Too long. Stuff some in our cache. */ |
5513
|
16
|
|
|
|
|
STRLEN cached_len = got_p + got_len - prune_from; |
5514
|
|
|
|
|
|
SV *const cache = datasv; |
5515
|
|
|
|
|
|
|
5516
|
|
|
|
|
|
if (SvOK(cache)) { |
5517
|
|
|
|
|
|
/* Cache should be empty. */ |
5518
|
|
|
|
|
|
assert(!SvCUR(cache)); |
5519
|
|
|
|
|
|
} |
5520
|
|
|
|
|
|
|
5521
|
16
|
|
|
|
|
sv_setpvn(cache, prune_from, cached_len); |
5522
|
|
|
|
|
|
/* If you ask for block mode, you may well split UTF-8 characters. |
5523
|
|
|
|
|
|
"If it breaks, you get to keep both parts" |
5524
|
|
|
|
|
|
(Your code is broken if you don't put them back together again |
5525
|
|
|
|
|
|
before something notices.) */ |
5526
|
16
|
50
|
|
|
|
if (SvUTF8(upstream)) { |
5527
|
0
|
|
|
|
|
SvUTF8_on(cache); |
5528
|
|
|
|
|
|
} |
5529
|
16
|
100
|
|
|
|
if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); |
5530
|
|
|
|
|
|
else |
5531
|
|
|
|
|
|
/* Cannot just use sv_setpvn, as that could free the buffer |
5532
|
|
|
|
|
|
before we have a chance to assign it. */ |
5533
|
2
|
|
|
|
|
sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), |
5534
|
|
|
|
|
|
got_len - cached_len); |
5535
|
16
|
|
|
|
|
*prune_from = 0; |
5536
|
|
|
|
|
|
/* Can't yet be EOF */ |
5537
|
16
|
50
|
|
|
|
if (status == 0) |
5538
|
|
|
|
|
|
status = 1; |
5539
|
|
|
|
|
|
} |
5540
|
|
|
|
|
|
|
5541
|
|
|
|
|
|
/* If they are at EOF but buf_sv has something in it, then they may never |
5542
|
|
|
|
|
|
have touched the SV upstream, so it may be undefined. If we naively |
5543
|
|
|
|
|
|
concatenate it then we get a warning about use of uninitialised value. |
5544
|
|
|
|
|
|
*/ |
5545
|
268
|
100
|
|
|
|
if (!err && upstream != buf_sv && |
|
|
100
|
|
|
|
|
5546
|
30
|
50
|
|
|
|
SvOK(upstream)) { |
|
|
50
|
|
|
|
|
5547
|
24
|
|
|
|
|
sv_catsv_nomg(buf_sv, upstream); |
5548
|
|
|
|
|
|
} |
5549
|
226
|
100
|
|
|
|
else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
5550
|
|
|
|
|
|
|
5551
|
250
|
100
|
|
|
|
if (status <= 0) { |
5552
|
88
|
|
|
|
|
IoLINES(datasv) = 0; |
5553
|
88
|
100
|
|
|
|
if (filter_state) { |
5554
|
42
|
|
|
|
|
SvREFCNT_dec(filter_state); |
5555
|
42
|
|
|
|
|
IoTOP_GV(datasv) = NULL; |
5556
|
|
|
|
|
|
} |
5557
|
88
|
100
|
|
|
|
if (filter_sub) { |
5558
|
76
|
|
|
|
|
SvREFCNT_dec(filter_sub); |
5559
|
76
|
|
|
|
|
IoBOTTOM_GV(datasv) = NULL; |
5560
|
|
|
|
|
|
} |
5561
|
88
|
|
|
|
|
filter_del(S_run_user_filter); |
5562
|
|
|
|
|
|
} |
5563
|
|
|
|
|
|
|
5564
|
250
|
100
|
|
|
|
if (err) |
5565
|
8
|
|
|
|
|
croak_sv(err); |
5566
|
|
|
|
|
|
|
5567
|
242
|
100
|
|
|
|
if (status == 0 && read_from_cache) { |
|
|
100
|
|
|
|
|
5568
|
|
|
|
|
|
/* If we read some data from the cache (and by getting here it implies |
5569
|
|
|
|
|
|
that we emptied the cache) then we aren't yet at EOF, and mustn't |
5570
|
|
|
|
|
|
report that to our caller. */ |
5571
|
|
|
|
|
|
return 1; |
5572
|
|
|
|
|
|
} |
5573
|
330
|
|
|
|
|
return status; |
5574
|
989132277
|
|
|
|
|
} |
5575
|
|
|
|
|
|
|
5576
|
|
|
|
|
|
/* |
5577
|
|
|
|
|
|
* Local variables: |
5578
|
|
|
|
|
|
* c-indentation-style: bsd |
5579
|
|
|
|
|
|
* c-basic-offset: 4 |
5580
|
|
|
|
|
|
* indent-tabs-mode: nil |
5581
|
|
|
|
|
|
* End: |
5582
|
|
|
|
|
|
* |
5583
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
5584
|
|
|
|
|
|
*/ |