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