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
re-add the deprecation data for soundex and checktree
[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)
5db1eb8d
BF		 3073 DIE(aTHX_ "Can't find label %"SVf,
3074 SVfARG(newSVpvn_flags(label, label_len,
3075 SVs_TEMP | label_flags)));
a0d0e21e 3076
3b2447bc
RH		 3077 /* if we're leaving an eval, check before we pop any frames
3078 that we're not going to punt, otherwise the error
3079 won't be caught */
3080
3081 if (leaving_eval && *enterops && enterops[1]) {
3082 I32 i;
3083 for (i = 1; enterops[i]; i++)
3084 if (enterops[i]->op_type == OP_ENTERITER)
3085 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3086 }
3087
b500e03b
GG		 3088 if (*enterops && enterops[1]) {
3089 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3090 if (enterops[i])
3091 deprecate("\"goto\" to jump into a construct");
3092 }
3093
a0d0e21e
LW		 3094 /* pop unwanted frames */
3095
3096 if (ix < cxstack_ix) {
3097 I32 oldsave;
3098
3099 if (ix < 0)
3100 ix = 0;
3101 dounwind(ix);
3102 TOPBLOCK(cx);
3280af22 3103 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 3104 LEAVE_SCOPE(oldsave);
3105 }
3106
3107 /* push wanted frames */
3108
748a9306 3109 if (*enterops && enterops[1]) {
0bd48802 3110 OP * const oldop = PL_op;
33d34e4c
AE		 3111 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3112 for (; enterops[ix]; ix++) {
533c011a 3113 PL_op = enterops[ix];
84902520
TB		 3114 /* Eventually we may want to stack the needed arguments
3115 * for each op. For now, we punt on the hard ones. */
533c011a 3116 if (PL_op->op_type == OP_ENTERITER)
894356b3 3117 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
16c91539 3118 PL_op->op_ppaddr(aTHX);
a0d0e21e 3119 }
533c011a 3120 PL_op = oldop;
a0d0e21e
LW		 3121 }
3122 }
3123
3124 if (do_dump) {
a5f75d66 3125#ifdef VMS
6b88bc9c 3126 if (!retop) retop = PL_main_start;
a5f75d66 3127#endif
3280af22
NIS		 3128 PL_restartop = retop;
3129 PL_do_undump = TRUE;
a0d0e21e
LW		 3130
3131 my_unexec();
3132
3280af22
NIS		 3133 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3134 PL_do_undump = FALSE;
a0d0e21e
LW		 3135 }
3136
47c9d59f 3137 PERL_ASYNC_CHECK();
a0d0e21e
LW		 3138 RETURNOP(retop);
3139}
3140
3141PP(pp_exit)
3142{
97aff369 3143 dVAR;
39644a26 3144 dSP;
a0d0e21e
LW		 3145 I32 anum;
3146
3147 if (MAXARG < 1)
3148 anum = 0;
9d3c658e
FC		 3149 else if (!TOPs) {
3150 anum = 0; (void)POPs;
3151 }
ff0cee69 3152 else {
a0d0e21e 3153 anum = SvIVx(POPs);
d98f61e7
GS		 3154#ifdef VMS
3155 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 3156 anum = 0;
96e176bf 3157 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 3158#endif
3159 }
cc3604b1 3160 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC		 3161#ifdef PERL_MAD
3162 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3163 if (anum || !(PL_minus_c && PL_madskills))
3164 my_exit(anum);
3165#else
a0d0e21e 3166 my_exit(anum);
81d86705 3167#endif
3280af22 3168 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 3169 RETURN;
3170}
3171
a0d0e21e
LW		 3172/* Eval. */
3173
0824fdcb 3174STATIC void
cea2e8a9 3175S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 3176{
504618e9 3177 const char *s = SvPVX_const(sv);
890ce7af 3178 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 3179 I32 line = 1;
a0d0e21e 3180
7918f24d
NC		 3181 PERL_ARGS_ASSERT_SAVE_LINES;
3182
a0d0e21e 3183 while (s && s < send) {
f54cb97a 3184 const char *t;
b9f83d2f 3185 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 3186
1d963ff3 3187 t = (const char *)memchr(s, '\n', send - s);
a0d0e21e
LW		 3188 if (t)
3189 t++;
3190 else
3191 t = send;
3192
3193 sv_setpvn(tmpstr, s, t - s);
3194 av_store(array, line++, tmpstr);
3195 s = t;
3196 }
3197}
3198
22f16304
RU		 3199/*
3200=for apidoc docatch
3201
3202Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3203
32040 is used as continue inside eval,
3205
32063 is used for a die caught by an inner eval - continue inner loop
3207
3208See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3209establish a local jmpenv to handle exception traps.
3210
3211=cut
3212*/
0824fdcb 3213STATIC OP *
cea2e8a9 3214S_docatch(pTHX_ OP *o)
1e422769 3215{
97aff369 3216 dVAR;
6224f72b 3217 int ret;
06b5626a 3218 OP * const oldop = PL_op;
db36c5a1 3219 dJMPENV;
1e422769 3220
1e422769 3221#ifdef DEBUGGING
54310121 3222 assert(CATCH_GET == TRUE);
1e422769 3223#endif
312caa8e 3224 PL_op = o;
8bffa5f8 3225
14dd3ad8 3226 JMPENV_PUSH(ret);
6224f72b 3227 switch (ret) {
312caa8e 3228 case 0:
abd70938
DM		 3229 assert(cxstack_ix >= 0);
3230 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3231 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8 3232 redo_body:
85aaa934 3233 CALLRUNOPS(aTHX);
312caa8e
CS		 3234 break;
3235 case 3:
8bffa5f8 3236 /* die caught by an inner eval - continue inner loop */
febb3a6d
Z		 3237 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3238 PL_restartjmpenv = NULL;
312caa8e
CS		 3239 PL_op = PL_restartop;
3240 PL_restartop = 0;
3241 goto redo_body;
3242 }
3243 /* FALL THROUGH */
3244 default:
14dd3ad8 3245 JMPENV_POP;
533c011a 3246 PL_op = oldop;
6224f72b 3247 JMPENV_JUMP(ret);
118e2215 3248 assert(0); /* NOTREACHED */
1e422769 3249 }
14dd3ad8 3250 JMPENV_POP;
533c011a 3251 PL_op = oldop;
5f66b61c 3252 return NULL;
1e422769 3253}
3254
a3985cdc
DM		 3255
3256/*
3257=for apidoc find_runcv
3258
3259Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 3260If db_seqp is non_null, skip CVs that are in the DB package and populate
3261*db_seqp with the cop sequence number at the point that the DB:: code was
3262entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 3263than in the scope of the debugger itself).
a3985cdc
DM		 3264
3265=cut
3266*/
3267
3268CV*
d819b83a 3269Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 3270{
db4cf31d 3271 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
70794f7b
FC		 3272}
3273
3274/* If this becomes part of the API, it might need a better name. */
3275CV *
db4cf31d 3276Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
70794f7b 3277{
97aff369 3278 dVAR;
a3985cdc 3279 PERL_SI *si;
b4b0692a 3280 int level = 0;
a3985cdc 3281
d819b83a
DM		 3282 if (db_seqp)
3283 *db_seqp = PL_curcop->cop_seq;
a3985cdc 3284 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 3285 I32 ix;
a3985cdc 3286 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 3287 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
70794f7b 3288 CV *cv = NULL;
d819b83a 3289 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
70794f7b 3290 cv = cx->blk_sub.cv;
d819b83a
DM		 3291 /* skip DB:: code */
3292 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3293 *db_seqp = cx->blk_oldcop->cop_seq;
3294 continue;
3295 }
a453e28a
DM		 3296 if (cx->cx_type & CXp_SUB_RE)
3297 continue;
d819b83a 3298 }
a3985cdc 3299 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
70794f7b
FC		 3300 cv = cx->blk_eval.cv;
3301 if (cv) {
3302 switch (cond) {
db4cf31d
FC		 3303 case FIND_RUNCV_padid_eq:
3304 if (!CvPADLIST(cv)
a56015b9 3305 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
8771da69 3306 continue;
b4b0692a
FC		 3307 return cv;
3308 case FIND_RUNCV_level_eq:
db4cf31d 3309 if (level++ != arg) continue;
70794f7b
FC		 3310 /* GERONIMO! */
3311 default:
3312 return cv;
3313 }
3314 }
a3985cdc
DM		 3315 }
3316 }
db4cf31d 3317 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
a3985cdc
DM		 3318}
3319
3320
27e90453
DM		 3321/* Run yyparse() in a setjmp wrapper. Returns:
3322 * 0: yyparse() successful
3323 * 1: yyparse() failed
3324 * 3: yyparse() died
3325 */
3326STATIC int
28ac2b49 3327S_try_yyparse(pTHX_ int gramtype)
27e90453
DM		 3328{
3329 int ret;
3330 dJMPENV;
3331
3332 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3333 JMPENV_PUSH(ret);
3334 switch (ret) {
3335 case 0:
28ac2b49 3336 ret = yyparse(gramtype) ? 1 : 0;
27e90453
DM		 3337 break;
3338 case 3:
3339 break;
3340 default:
3341 JMPENV_POP;
3342 JMPENV_JUMP(ret);
118e2215 3343 assert(0); /* NOTREACHED */
27e90453
DM		 3344 }
3345 JMPENV_POP;
3346 return ret;
3347}
3348
3349
104a8185
DM		 3350/* Compile a require/do or an eval ''.
3351 *
a3985cdc 3352 * outside is the lexically enclosing CV (if any) that invoked us.
104a8185
DM		 3353 * seq is the current COP scope value.
3354 * hh is the saved hints hash, if any.
3355 *
410be5db 3356 * Returns a bool indicating whether the compile was successful; if so,
104a8185
DM		 3357 * PL_eval_start contains the first op of the compiled code; otherwise,
3358 * pushes undef.
3359 *
3360 * This function is called from two places: pp_require and pp_entereval.
3361 * These can be distinguished by whether PL_op is entereval.
7d116edc
FC		 3362 */
3363
410be5db 3364STATIC bool
104a8185 3365S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
a0d0e21e 3366{
27da23d5 3367 dVAR; dSP;
46c461b5 3368 OP * const saveop = PL_op;
104a8185 3369 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
f45b078d 3370 COP * const oldcurcop = PL_curcop;
26c9400e 3371 bool in_require = (saveop->op_type == OP_REQUIRE);
27e90453 3372 int yystatus;
676a678a 3373 CV *evalcv;
a0d0e21e 3374
27e90453 3375 PL_in_eval = (in_require
6dc8a9e4 3376 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
a1941760
DM		 3377 : (EVAL_INEVAL |
3378 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3379 ? EVAL_RE_REPARSING : 0)));
a0d0e21e 3380
1ce6579f 3381 PUSHMARK(SP);
3382
676a678a
Z		 3383 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3384 CvEVAL_on(evalcv);
2090ab20 3385 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
676a678a 3386 cxstack[cxstack_ix].blk_eval.cv = evalcv;
86a64801 3387 cxstack[cxstack_ix].blk_gimme = gimme;
2090ab20 3388
676a678a
Z		 3389 CvOUTSIDE_SEQ(evalcv) = seq;
3390 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
a3985cdc 3391
dd2155a4 3392 /* set up a scratch pad */
a0d0e21e 3393
676a678a 3394 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
cecbe010 3395 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2c05e328 3396
07055b4c 3397
81d86705 3398 if (!PL_madskills)
676a678a 3399 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
748a9306 3400
a0d0e21e
LW		 3401 /* make sure we compile in the right package */
3402
ed094faf 3403 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
03d9f026 3404 SAVEGENERICSV(PL_curstash);
cb1ad50e
FC		 3405 PL_curstash = (HV *)CopSTASH(PL_curcop);
3406 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3407 else SvREFCNT_inc_simple_void(PL_curstash);
a0d0e21e 3408 }
3c10abe3 3409 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3280af22
NIS		 3410 SAVESPTR(PL_beginav);
3411 PL_beginav = newAV();
3412 SAVEFREESV(PL_beginav);
3c10abe3
AG		 3413 SAVESPTR(PL_unitcheckav);
3414 PL_unitcheckav = newAV();
3415 SAVEFREESV(PL_unitcheckav);
a0d0e21e 3416
81d86705 3417#ifdef PERL_MAD
9da243ce 3418 SAVEBOOL(PL_madskills);
81d86705
NC		 3419 PL_madskills = 0;
3420#endif
3421
104a8185 3422 ENTER_with_name("evalcomp");
676a678a
Z		 3423 SAVESPTR(PL_compcv);
3424 PL_compcv = evalcv;
3425
a0d0e21e
LW		 3426 /* try to compile it */
3427
5f66b61c 3428 PL_eval_root = NULL;
3280af22 3429 PL_curcop = &PL_compiling;
26c9400e 3430 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 3431 PL_in_eval |= EVAL_KEEPERR;
ab69dbc2
RGS		 3432 else
3433 CLEAR_ERRSV();
27e90453 3434
377b5421
DM		 3435 SAVEHINTS();
3436 if (clear_hints) {
3437 PL_hints = 0;
3438 hv_clear(GvHV(PL_hintgv));
3439 }
3440 else {
3441 PL_hints = saveop->op_private & OPpEVAL_COPHH
3442 ? oldcurcop->cop_hints : saveop->op_targ;
4f3e2518
DM		 3443
3444 /* making 'use re eval' not be in scope when compiling the
3445 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3446 * infinite recursion when S_has_runtime_code() gives a false
3447 * positive: the second time round, HINT_RE_EVAL isn't set so we
3448 * don't bother calling S_has_runtime_code() */
3449 if (PL_in_eval & EVAL_RE_REPARSING)
3450 PL_hints &= ~HINT_RE_EVAL;
3451
377b5421
DM		 3452 if (hh) {
3453 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3454 SvREFCNT_dec(GvHV(PL_hintgv));
3455 GvHV(PL_hintgv) = hh;
3456 }
3457 }
3458 SAVECOMPILEWARNINGS();
3459 if (clear_hints) {
3460 if (PL_dowarn & G_WARN_ALL_ON)
3461 PL_compiling.cop_warnings = pWARN_ALL ;
3462 else if (PL_dowarn & G_WARN_ALL_OFF)
3463 PL_compiling.cop_warnings = pWARN_NONE ;
3464 else
3465 PL_compiling.cop_warnings = pWARN_STD ;
3466 }
3467 else {
3468 PL_compiling.cop_warnings =
3469 DUP_WARNINGS(oldcurcop->cop_warnings);
3470 cophh_free(CopHINTHASH_get(&PL_compiling));
3471 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3472 /* The label, if present, is the first entry on the chain. So rather
3473 than writing a blank label in front of it (which involves an
3474 allocation), just use the next entry in the chain. */
3475 PL_compiling.cop_hints_hash
3476 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3477 /* Check the assumption that this removed the label. */
3478 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
f45b078d 3479 }
377b5421
DM		 3480 else
3481 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3482 }
f45b078d 3483
a88d97bf 3484 CALL_BLOCK_HOOKS(bhk_eval, saveop);
52db365a 3485
27e90453
DM		 3486 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3487 * so honour CATCH_GET and trap it here if necessary */
3488
28ac2b49 3489 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
27e90453
DM		 3490
3491 if (yystatus || PL_parser->error_count || !PL_eval_root) {
0c58d367 3492 SV **newsp; /* Used by POPBLOCK. */
d164302a 3493 PERL_CONTEXT *cx;
27e90453 3494 I32 optype; /* Used by POPEVAL. */
d164302a 3495 SV *namesv;
eed484f9 3496 SV *errsv = NULL;
bfed75c6 3497
d164302a
GG		 3498 cx = NULL;
3499 namesv = NULL;
27e90453
DM		 3500 PERL_UNUSED_VAR(newsp);
3501 PERL_UNUSED_VAR(optype);
3502
c86ffc32
DM		 3503 /* note that if yystatus == 3, then the EVAL CX block has already
3504 * been popped, and various vars restored */
533c011a 3505 PL_op = saveop;
27e90453 3506 if (yystatus != 3) {
c86ffc32
DM		 3507 if (PL_eval_root) {
3508 op_free(PL_eval_root);
3509 PL_eval_root = NULL;
3510 }
27e90453 3511 SP = PL_stack_base + POPMARK; /* pop original mark */
377b5421
DM		 3512 POPBLOCK(cx,PL_curpm);
3513 POPEVAL(cx);
3514 namesv = cx->blk_eval.old_namesv;
bbde7ba3 3515 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
27e90453 3516 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
cd6472fc 3517 }
9d4ba2ae 3518
eed484f9 3519 errsv = ERRSV;
27e90453 3520 if (in_require) {
b6494f15
VP		 3521 if (!cx) {
3522 /* If cx is still NULL, it means that we didn't go in the
3523 * POPEVAL branch. */
3524 cx = &cxstack[cxstack_ix];
3525 assert(CxTYPE(cx) == CXt_EVAL);
3526 namesv = cx->blk_eval.old_namesv;
3527 }
3528 (void)hv_store(GvHVn(PL_incgv),
ecad31f0 3529 SvPVX_const(namesv),
c60dbbc3 3530 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
b6494f15 3531 &PL_sv_undef, 0);
ecad31f0 3532 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
eed484f9
DD		 3533 SVfARG(errsv
3534 ? errsv
ecad31f0 3535 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
5a844595 3536 }
9d7f88dd 3537 else {
eed484f9
DD		 3538 if (!*(SvPV_nolen_const(errsv))) {
3539 sv_setpvs(errsv, "Compilation error");
9d7f88dd
SR		 3540 }
3541 }
2bf54cc6 3542 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
410be5db
DM		 3543 PUTBACK;
3544 return FALSE;
a0d0e21e 3545 }
104a8185
DM		 3546 else
3547 LEAVE_with_name("evalcomp");
3548
57843af0 3549 CopLINE_set(&PL_compiling, 0);
104a8185 3550 SAVEFREEOP(PL_eval_root);
8be227ab 3551 cv_forget_slab(evalcv);
0c58d367 3552
a0d0e21e
LW		 3553 DEBUG_x(dump_eval());
3554
55497cff 3555 /* Register with debugger: */
26c9400e 3556 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
b96d8cd9 3557 CV * const cv = get_cvs("DB::postponed", 0);
55497cff 3558 if (cv) {
3559 dSP;
924508f0 3560 PUSHMARK(SP);
ad64d0ec 3561 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
55497cff 3562 PUTBACK;
ad64d0ec 3563 call_sv(MUTABLE_SV(cv), G_DISCARD);
55497cff 3564 }
3565 }
3566
8ed49485
FC		 3567 if (PL_unitcheckav) {
3568 OP *es = PL_eval_start;
3c10abe3 3569 call_list(PL_scopestack_ix, PL_unitcheckav);
8ed49485
FC		 3570 PL_eval_start = es;
3571 }
3c10abe3 3572
a0d0e21e
LW		 3573 /* compiled okay, so do it */
3574
676a678a 3575 CvDEPTH(evalcv) = 1;
3280af22 3576 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3577 PL_op = saveop; /* The caller may need it. */
bc177e6b 3578 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3579
410be5db
DM		 3580 PUTBACK;
3581 return TRUE;
a0d0e21e
LW		 3582}
3583
a6c40364 3584STATIC PerlIO *
282b29ee 3585S_check_type_and_open(pTHX_ SV *name)
ce8abf5f
SP		 3586{
3587 Stat_t st;
282b29ee
NC		 3588 const char *p = SvPV_nolen_const(name);
3589 const int st_rc = PerlLIO_stat(p, &st);
df528165 3590
7918f24d
NC		 3591 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3592
6b845e56 3593 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
4608196e 3594 return NULL;
ce8abf5f
SP		 3595 }
3596
ccb84406 3597#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
639dfab0 3598 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
ccb84406 3599#else
282b29ee 3600 return PerlIO_open(p, PERL_SCRIPT_MODE);
ccb84406 3601#endif
ce8abf5f
SP		 3602}
3603
75c20bac 3604#ifndef PERL_DISABLE_PMC
ce8abf5f 3605STATIC PerlIO *
282b29ee 3606S_doopen_pm(pTHX_ SV *name)
b295d113 3607{
282b29ee
NC		 3608 STRLEN namelen;
3609 const char *p = SvPV_const(name, namelen);
b295d113 3610
7918f24d
NC		 3611 PERL_ARGS_ASSERT_DOOPEN_PM;
3612
282b29ee 3613 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
eb70bb4a 3614 SV *const pmcsv = sv_newmortal();
a6c40364 3615 Stat_t pmcstat;
50b8ed39 3616
eb70bb4a 3617 SvSetSV_nosteal(pmcsv,name);
282b29ee 3618 sv_catpvn(pmcsv, "c", 1);
50b8ed39 3619
282b29ee
NC		 3620 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3621 return check_type_and_open(pmcsv);
a6c40364 3622 }
282b29ee 3623 return check_type_and_open(name);
75c20bac 3624}
7925835c 3625#else
282b29ee 3626# define doopen_pm(name) check_type_and_open(name)
7925835c 3627#endif /* !PERL_DISABLE_PMC */
b295d113 3628
511712dc
TC		 3629/* require doesn't search for absolute names, or when the name is
3630 explicity relative the current directory */
3631PERL_STATIC_INLINE bool
3632S_path_is_searchable(const char *name)
3633{
3634 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3635
3636 if (PERL_FILE_IS_ABSOLUTE(name)
3637#ifdef WIN32
3638 || (*name == '.' && ((name[1] == '/' ||
3639 (name[1] == '.' && name[2] == '/'))
3640 || (name[1] == '\\' ||
3641 ( name[1] == '.' && name[2] == '\\')))
3642 )
3643#else
3644 || (*name == '.' && (name[1] == '/' ||
3645 (name[1] == '.' && name[2] == '/')))
3646#endif
3647 )
3648 {
3649 return FALSE;
3650 }
3651 else
3652 return TRUE;
3653}
3654
a0d0e21e
LW		 3655PP(pp_require)
3656{
27da23d5 3657 dVAR; dSP;
eb578fdb 3658 PERL_CONTEXT *cx;
a0d0e21e 3659 SV *sv;
5c144d81 3660 const char *name;
6132ea6c 3661 STRLEN len;
4492be7a
JM		 3662 char * unixname;
3663 STRLEN unixlen;
62f5ad7a 3664#ifdef VMS
4492be7a 3665 int vms_unixname = 0;
155f4c25
CB		 3666 char *unixnamebuf;
3667 char *unixdir;
3668 char *unixdirbuf;
62f5ad7a 3669#endif
c445ea15
AL		 3670 const char *tryname = NULL;
3671 SV *namesv = NULL;
f54cb97a 3672 const I32 gimme = GIMME_V;
bbed91b5 3673 int filter_has_file = 0;
c445ea15 3674 PerlIO *tryrsfp = NULL;
34113e50 3675 SV *filter_cache = NULL;
c445ea15
AL		 3676 SV *filter_state = NULL;
3677 SV *filter_sub = NULL;
3678 SV *hook_sv = NULL;
6ec9efec
JH		 3679 SV *encoding;
3680 OP *op;
83b195e4 3681 int saved_errno;
511712dc 3682 bool path_searchable;
a0d0e21e
LW		 3683
3684 sv = POPs;
d7aa5382 3685 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
d086148c 3686 sv = sv_2mortal(new_version(sv));
88010bae 3687 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
ac0e6a2f 3688 upg_version(PL_patchlevel, TRUE);
149c1637 3689 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3cacfbb9 3690 if ( vcmp(sv,PL_patchlevel) <= 0 )
468aa647 3691 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
e753e3b1
FC		 3692 SVfARG(sv_2mortal(vnormal(sv))),
3693 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3694 );
468aa647
RGS		 3695 }
3696 else {
d1029faa
JP		 3697 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3698 I32 first = 0;
3699 AV *lav;
3700 SV * const req = SvRV(sv);
85fbaab2 3701 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
d1029faa
JP		 3702
3703 /* get the left hand term */
502c6561 3704 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
d1029faa
JP		 3705
3706 first = SvIV(*av_fetch(lav,0,0));
3707 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
85fbaab2 3708 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
d1029faa
JP		 3709 || av_len(lav) > 1 /* FP with > 3 digits */
3710 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3711 ) {
3712 DIE(aTHX_ "Perl %"SVf" required--this is only "
9d056fb0
FC		 3713 "%"SVf", stopped",
3714 SVfARG(sv_2mortal(vnormal(req))),
3715 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3716 );
d1029faa
JP		 3717 }
3718 else { /* probably 'use 5.10' or 'use 5.8' */
af61dbfd 3719 SV *hintsv;
d1029faa
JP		 3720 I32 second = 0;
3721
3722 if (av_len(lav)>=1)
3723 second = SvIV(*av_fetch(lav,1,0));
3724
3725 second /= second >= 600 ? 100 : 10;
af61dbfd
NC		 3726 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3727 (int)first, (int)second);
d1029faa
JP		 3728 upg_version(hintsv, TRUE);
3729
3730 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3731 "--this is only %"SVf", stopped",
1be7d6f3
FC		 3732 SVfARG(sv_2mortal(vnormal(req))),
3733 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3734 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3735 );
d1029faa
JP		 3736 }
3737 }
468aa647 3738 }
d7aa5382 3739
7dfde25d 3740 RETPUSHYES;
a0d0e21e 3741 }
5c144d81 3742 name = SvPV_const(sv, len);
6132ea6c 3743 if (!(name && len > 0 && *name))
cea2e8a9 3744 DIE(aTHX_ "Null filename used");
4633a7c4 3745 TAINT_PROPER("require");
4492be7a 3746
511712dc 3747 path_searchable = path_is_searchable(name);
4492be7a
JM		 3748
3749#ifdef VMS
3750 /* The key in the %ENV hash is in the syntax of file passed as the argument
3751 * usually this is in UNIX format, but sometimes in VMS format, which
3752 * can result in a module being pulled in more than once.
3753 * To prevent this, the key must be stored in UNIX format if the VMS
3754 * name can be translated to UNIX.
3755 */
155f4c25
CB		 3756
3757 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3758 && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
4492be7a
JM		 3759 unixlen = strlen(unixname);
3760 vms_unixname = 1;
3761 }
3762 else
3763#endif
3764 {
3765 /* if not VMS or VMS name can not be translated to UNIX, pass it
3766 * through.
3767 */
3768 unixname = (char *) name;
3769 unixlen = len;
3770 }
44f8325f 3771 if (PL_op->op_type == OP_REQUIRE) {
4492be7a
JM		 3772 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3773 unixname, unixlen, 0);
44f8325f
AL		 3774 if ( svp ) {
3775 if (*svp != &PL_sv_undef)
3776 RETPUSHYES;
3777 else
087b5369
RD		 3778 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3779 "Compilation failed in require", unixname);
44f8325f 3780 }
4d8b06f1 3781 }
a0d0e21e 3782
32aeab29
SM		 3783 LOADING_FILE_PROBE(unixname);
3784
a0d0e21e
LW		 3785 /* prepare to compile file */
3786
511712dc 3787 if (!path_searchable) {
282b29ee 3788 /* At this point, name is SvPVX(sv) */
46fc3d4c 3789 tryname = name;
282b29ee 3790 tryrsfp = doopen_pm(sv);
bf4acbe4 3791 }
511712dc 3792 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
44f8325f 3793 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3794 I32 i;
748a9306 3795#ifdef VMS
4492be7a 3796 if (vms_unixname)
46fc3d4c 3797#endif
3798 {
d0328fd7 3799 namesv = newSV_type(SVt_PV);
46fc3d4c 3800 for (i = 0; i <= AvFILL(ar); i++) {
df528165 3801 SV * const dirsv = *av_fetch(ar, i, TRUE);
bbed91b5 3802
ad64d0ec 3803 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
c38a6530 3804 mg_get(dirsv);
bbed91b5
KF		 3805 if (SvROK(dirsv)) {
3806 int count;
a3b58a99 3807 SV **svp;
bbed91b5
KF		 3808 SV *loader = dirsv;
3809
e14e2dc8
NC		 3810 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3811 && !sv_isobject(loader))
3812 {
502c6561 3813 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
bbed91b5
KF		 3814 }
3815
b900a521 3816 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3817 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3818 tryname = SvPVX_const(namesv);
c445ea15 3819 tryrsfp = NULL;
bbed91b5 3820
d343c3ef 3821 ENTER_with_name("call_INC");
bbed91b5
KF		 3822 SAVETMPS;
3823 EXTEND(SP, 2);
3824
3825 PUSHMARK(SP);
3826 PUSHs(dirsv);
3827 PUSHs(sv);
3828 PUTBACK;
e982885c
NC		 3829 if (sv_isobject(loader))
3830 count = call_method("INC", G_ARRAY);
3831 else
3832 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3833 SPAGAIN;
3834
3835 if (count > 0) {
3836 int i = 0;
3837 SV *arg;
3838
3839 SP -= count - 1;
3840 arg = SP[i++];
3841
34113e50
NC		 3842 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3843 && !isGV_with_GP(SvRV(arg))) {
3844 filter_cache = SvRV(arg);
74c765eb 3845 SvREFCNT_inc_simple_void_NN(filter_cache);
34113e50
NC		 3846
3847 if (i < count) {
3848 arg = SP[i++];
3849 }
3850 }
3851
6e592b3a 3852 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
bbed91b5
KF		 3853 arg = SvRV(arg);
3854 }
3855
6e592b3a 3856 if (isGV_with_GP(arg)) {
159b6efe 3857 IO * const io = GvIO((const GV *)arg);
bbed91b5
KF		 3858
3859 ++filter_has_file;
3860
3861 if (io) {
3862 tryrsfp = IoIFP(io);
0f7de14d
NC		 3863 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3864 PerlIO_close(IoOFP(io));
bbed91b5 3865 }
0f7de14d
NC		 3866 IoIFP(io) = NULL;
3867 IoOFP(io) = NULL;
bbed91b5
KF		 3868 }
3869
3870 if (i < count) {
3871 arg = SP[i++];
3872 }
3873 }
3874
3875 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3876 filter_sub = arg;
74c765eb 3877 SvREFCNT_inc_simple_void_NN(filter_sub);
bbed91b5
KF		 3878
3879 if (i < count) {
3880 filter_state = SP[i];
b37c2d43 3881 SvREFCNT_inc_simple_void(filter_state);
bbed91b5 3882 }
34113e50 3883 }
bbed91b5 3884
34113e50
NC		 3885 if (!tryrsfp && (filter_cache || filter_sub)) {
3886 tryrsfp = PerlIO_open(BIT_BUCKET,
3887 PERL_SCRIPT_MODE);
bbed91b5 3888 }
1d06aecd 3889 SP--;
bbed91b5
KF		 3890 }
3891
3892 PUTBACK;
3893 FREETMPS;
d343c3ef 3894 LEAVE_with_name("call_INC");
bbed91b5 3895
c5f55552
NC		 3896 /* Adjust file name if the hook has set an %INC entry.
3897 This needs to happen after the FREETMPS above. */
3898 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3899 if (svp)
3900 tryname = SvPV_nolen_const(*svp);
3901
bbed91b5 3902 if (tryrsfp) {
89ccab8c 3903 hook_sv = dirsv;
bbed91b5
KF		 3904 break;
3905 }
3906
3907 filter_has_file = 0;
34113e50
NC		 3908 if (filter_cache) {
3909 SvREFCNT_dec(filter_cache);
3910 filter_cache = NULL;
3911 }
bbed91b5
KF		 3912 if (filter_state) {
3913 SvREFCNT_dec(filter_state);
c445ea15 3914 filter_state = NULL;
bbed91b5
KF		 3915 }
3916 if (filter_sub) {
3917 SvREFCNT_dec(filter_sub);
c445ea15 3918 filter_sub = NULL;
bbed91b5
KF		 3919 }
3920 }
3921 else {
511712dc 3922 if (path_searchable) {
b640a14a
NC		 3923 const char *dir;
3924 STRLEN dirlen;
3925
3926 if (SvOK(dirsv)) {
3927 dir = SvPV_const(dirsv, dirlen);
3928 } else {
3929 dir = "";
3930 dirlen = 0;
3931 }
3932
e37778c2 3933#ifdef VMS
155f4c25
CB		 3934 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3935 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
bbed91b5
KF		 3936 continue;
3937 sv_setpv(namesv, unixdir);
3938 sv_catpv(namesv, unixname);
e37778c2
NC		 3939#else
3940# ifdef __SYMBIAN32__
27da23d5
JH		 3941 if (PL_origfilename[0] &&
3942 PL_origfilename[1] == ':' &&
3943 !(dir[0] && dir[1] == ':'))
3944 Perl_sv_setpvf(aTHX_ namesv,
3945 "%c:%s\\%s",
3946 PL_origfilename[0],
3947 dir, name);
3948 else
3949 Perl_sv_setpvf(aTHX_ namesv,
3950 "%s\\%s",
3951 dir, name);
e37778c2 3952# else
b640a14a
NC		 3953 /* The equivalent of
3954 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3955 but without the need to parse the format string, or
3956 call strlen on either pointer, and with the correct
3957 allocation up front. */
3958 {
3959 char *tmp = SvGROW(namesv, dirlen + len + 2);
3960
3961 memcpy(tmp, dir, dirlen);
3962 tmp +=dirlen;
6b0bdd7f
MH		 3963
3964 /* Avoid '<dir>//<file>' */
3965 if (!dirlen || *(tmp-1) != '/') {
3966 *tmp++ = '/';
3967 }
3968
b640a14a
NC		 3969 /* name came from an SV, so it will have a '\0' at the
3970 end that we can copy as part of this memcpy(). */
3971 memcpy(tmp, name, len + 1);
3972
3973 SvCUR_set(namesv, dirlen + len + 1);
282b29ee 3974 SvPOK_on(namesv);
b640a14a 3975 }
27da23d5 3976# endif
bf4acbe4 3977#endif
bbed91b5 3978 TAINT_PROPER("require");
349d4f2f 3979 tryname = SvPVX_const(namesv);
282b29ee 3980 tryrsfp = doopen_pm(namesv);
bbed91b5 3981 if (tryrsfp) {
e63be746
RGS		 3982 if (tryname[0] == '.' && tryname[1] == '/') {
3983 ++tryname;
4910606a 3984 while (*++tryname == '/') {}
e63be746 3985 }
bbed91b5
KF		 3986 break;
3987 }
2433d39e
BF		 3988 else if (errno == EMFILE || errno == EACCES) {
3989 /* no point in trying other paths if out of handles;
3990 * on the other hand, if we couldn't open one of the
3991 * files, then going on with the search could lead to
3992 * unexpected results; see perl #113422
3993 */
3994 break;
3995 }
be4b629d 3996 }
46fc3d4c 3997 }
a0d0e21e
LW		 3998 }
3999 }
4000 }
83b195e4 4001 saved_errno = errno; /* sv_2mortal can realloc things */
b2ef6d44 4002 sv_2mortal(namesv);
a0d0e21e 4003 if (!tryrsfp) {
533c011a 4004 if (PL_op->op_type == OP_REQUIRE) {
83b195e4 4005 if(saved_errno == EMFILE || saved_errno == EACCES) {
c9d5e35e 4006 /* diag_listed_as: Can't locate %s */
83b195e4 4007 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
e31de809
SP		 4008 } else {
4009 if (namesv) { /* did we lookup @INC? */
44f8325f 4010 AV * const ar = GvAVn(PL_incgv);
e31de809 4011 I32 i;
1e5f02b3 4012 SV *const msg = newSVpvs_flags("", SVs_TEMP);
c9d5e35e
NC		 4013 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4014 for (i = 0; i <= AvFILL(ar); i++) {
4015 sv_catpvs(inc, " ");
4016 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4017 }
f7ee53b5
PJ		 4018 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4019 const char *c, *e = name + len - 3;
4020 sv_catpv(msg, " (you may need to install the ");
4021 for (c = name; c < e; c++) {
4022 if (*c == '/') {
4023 sv_catpvn(msg, "::", 2);
4024 }
4025 else {
4026 sv_catpvn(msg, c, 1);
4027 }
4028 }
4029 sv_catpv(msg, " module)");
4030 }
4031 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4032 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4033 }
4034 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4035 sv_catpv(msg, " (did you run h2ph?)");
4036 }
c9d5e35e
NC		 4037
4038 /* diag_listed_as: Can't locate %s */
4039 DIE(aTHX_
f7ee53b5
PJ		 4040 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4041 name, msg, inc);
c9d5e35e 4042 }
2683423c 4043 }
c9d5e35e 4044 DIE(aTHX_ "Can't locate %s", name);
a0d0e21e
LW		 4045 }
4046
a3ff80c1 4047 CLEAR_ERRSV();
a0d0e21e
LW		 4048 RETPUSHUNDEF;
4049 }
d8bfb8bd 4050 else
93189314 4051 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 4052
4053 /* Assume success here to prevent recursive requirement. */
238d24b4 4054 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 4055 /* Check whether a hook in @INC has already filled %INC */
44f8325f 4056 if (!hook_sv) {
4492be7a 4057 (void)hv_store(GvHVn(PL_incgv),
b2ef6d44 4058 unixname, unixlen, newSVpv(tryname,0),0);
44f8325f 4059 } else {
4492be7a 4060 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
44f8325f 4061 if (!svp)
4492be7a
JM		 4062 (void)hv_store(GvHVn(PL_incgv),
4063 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
d3a4e64e 4064 }
a0d0e21e 4065
d343c3ef 4066 ENTER_with_name("eval");
a0d0e21e 4067 SAVETMPS;
b2ef6d44
FC		 4068 SAVECOPFILE_FREE(&PL_compiling);
4069 CopFILE_set(&PL_compiling, tryname);
8eaa0acf 4070 lex_start(NULL, tryrsfp, 0);
e50aee73 4071
34113e50 4072 if (filter_sub || filter_cache) {
4464f08e
NC		 4073 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4074 than hanging another SV from it. In turn, filter_add() optionally
4075 takes the SV to use as the filter (or creates a new SV if passed
4076 NULL), so simply pass in whatever value filter_cache has. */
4077 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
bbed91b5 4078 IoLINES(datasv) = filter_has_file;
159b6efe
NC		 4079 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4080 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
bbed91b5
KF		 4081 }
4082
4083 /* switch to eval mode */
a0d0e21e 4084 PUSHBLOCK(cx, CXt_EVAL, SP);
6b75f042 4085 PUSHEVAL(cx, name);
f39bc417 4086 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 4087
57843af0
GS		 4088 SAVECOPLINE(&PL_compiling);
4089 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 4090
4091 PUTBACK;
6ec9efec
JH		 4092
4093 /* Store and reset encoding. */
4094 encoding = PL_encoding;
c445ea15 4095 PL_encoding = NULL;
6ec9efec 4096
104a8185 4097 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
410be5db
DM		 4098 op = DOCATCH(PL_eval_start);
4099 else
4100 op = PL_op->op_next;
bfed75c6 4101
6ec9efec
JH		 4102 /* Restore encoding. */
4103 PL_encoding = encoding;
4104
32aeab29
SM		 4105 LOADED_FILE_PROBE(unixname);
4106
6ec9efec 4107 return op;
a0d0e21e
LW		 4108}
4109
996c9baa
VP		 4110/* This is a op added to hold the hints hash for
4111 pp_entereval. The hash can be modified by the code
4112 being eval'ed, so we return a copy instead. */
4113
4114PP(pp_hintseval)
4115{
4116 dVAR;
4117 dSP;
defdfed5 4118 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
996c9baa
VP		 4119 RETURN;
4120}
4121
4122
a0d0e21e
LW		 4123PP(pp_entereval)
4124{
27da23d5 4125 dVAR; dSP;
eb578fdb 4126 PERL_CONTEXT *cx;
0d863452 4127 SV *sv;
890ce7af 4128 const I32 gimme = GIMME_V;
fd06b02c 4129 const U32 was = PL_breakable_sub_gen;
83ee9e09 4130 char tbuf[TYPE_DIGITS(long) + 12];
78da7625 4131 bool saved_delete = FALSE;
83ee9e09 4132 char *tmpbuf = tbuf;
a0d0e21e 4133 STRLEN len;
a3985cdc 4134 CV* runcv;
0abcdfa4 4135 U32 seq, lex_flags = 0;
c445ea15 4136 HV *saved_hh = NULL;
60d63348 4137 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
e389bba9 4138
0d863452 4139 if (PL_op->op_private & OPpEVAL_HAS_HH) {
85fbaab2 4140 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
0d863452 4141 }
bc344123
FC		 4142 else if (PL_hints & HINT_LOCALIZE_HH || (
4143 PL_op->op_private & OPpEVAL_COPHH
4144 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4145 )) {
7d789282
FC		 4146 saved_hh = cop_hints_2hv(PL_curcop, 0);
4147 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4148 }
0d863452 4149 sv = POPs;
895b760f
DM		 4150 if (!SvPOK(sv)) {
4151 /* make sure we've got a plain PV (no overload etc) before testing
4152 * for taint. Making a copy here is probably overkill, but better
4153 * safe than sorry */
0479a84a
NC		 4154 STRLEN len;
4155 const char * const p = SvPV_const(sv, len);
4156
4157 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
0abcdfa4 4158 lex_flags |= LEX_START_COPIED;
7d789282 4159
60d63348 4160 if (bytes && SvUTF8(sv))
7d789282
FC		 4161 SvPVbyte_force(sv, len);
4162 }
60d63348 4163 else if (bytes && SvUTF8(sv)) {
e1fa07e3 4164 /* Don't modify someone else's scalar */
7d789282
FC		 4165 STRLEN len;
4166 sv = newSVsv(sv);
5cefc8c1 4167 (void)sv_2mortal(sv);
7d789282 4168 SvPVbyte_force(sv,len);
0abcdfa4 4169 lex_flags |= LEX_START_COPIED;
895b760f 4170 }
a0d0e21e 4171
af2d3def 4172 TAINT_IF(SvTAINTED(sv));
748a9306 4173 TAINT_PROPER("eval");
a0d0e21e 4174
d343c3ef 4175 ENTER_with_name("eval");
0abcdfa4 4176 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
60d63348
FC		 4177 ? LEX_IGNORE_UTF8_HINTS
4178 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
0abcdfa4 4179 )
60d63348 4180 );
748a9306 4181 SAVETMPS;
ac27b0f5 4182
a0d0e21e
LW		 4183 /* switch to eval mode */
4184
83ee9e09 4185 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
8b38226b
AL		 4186 SV * const temp_sv = sv_newmortal();
4187 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
83ee9e09
GS		 4188 (unsigned long)++PL_evalseq,
4189 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8b38226b
AL		 4190 tmpbuf = SvPVX(temp_sv);
4191 len = SvCUR(temp_sv);
83ee9e09
GS		 4192 }
4193 else
d9fad198 4194 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 4195 SAVECOPFILE_FREE(&PL_compiling);
57843af0 4196 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 4197 SAVECOPLINE(&PL_compiling);
57843af0 4198 CopLINE_set(&PL_compiling, 1);
d819b83a
DM		 4199 /* special case: an eval '' executed within the DB package gets lexically
4200 * placed in the first non-DB CV rather than the current CV - this
4201 * allows the debugger to execute code, find lexicals etc, in the
4202 * scope of the code being debugged. Passing &seq gets find_runcv
4203 * to do the dirty work for us */
4204 runcv = find_runcv(&seq);
a0d0e21e 4205
6b35e009 4206 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
6b75f042 4207 PUSHEVAL(cx, 0);
f39bc417 4208 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 4209
4210 /* prepare to compile string */
4211
a44e3ce2 4212 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
bdc0bf6f 4213 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
78da7625 4214 else {
c8cb8d55
FC		 4215 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4216 deleting the eval's FILEGV from the stash before gv_check() runs
4217 (i.e. before run-time proper). To work around the coredump that
4218 ensues, we always turn GvMULTI_on for any globals that were
4219 introduced within evals. See force_ident(). GSAR 96-10-12 */
78da7625
FC		 4220 char *const safestr = savepvn(tmpbuf, len);
4221 SAVEDELETE(PL_defstash, safestr, len);
4222 saved_delete = TRUE;
4223 }
4224
a0d0e21e 4225 PUTBACK;
f9bddea7 4226
104a8185 4227 if (doeval(gimme, runcv, seq, saved_hh)) {
f9bddea7
NC		 4228 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4229 ? (PERLDB_LINE || PERLDB_SAVESRC)
4230 : PERLDB_SAVESRC_NOSUBS) {
4231 /* Retain the filegv we created. */
78da7625 4232 } else if (!saved_delete) {
f9bddea7
NC		 4233 char *const safestr = savepvn(tmpbuf, len);
4234 SAVEDELETE(PL_defstash, safestr, len);
4235 }
4236 return DOCATCH(PL_eval_start);
4237 } else {
486ec47a 4238 /* We have already left the scope set up earlier thanks to the LEAVE
f9bddea7 4239 in doeval(). */
eb044b10
NC		 4240 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4241 ? (PERLDB_LINE || PERLDB_SAVESRC)
4242 : PERLDB_SAVESRC_INVALID) {
f9bddea7 4243 /* Retain the filegv we created. */
7857f360 4244 } else if (!saved_delete) {
f9bddea7
NC		 4245 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4246 }
4247 return PL_op->op_next;
4248 }
a0d0e21e
LW		 4249}
4250
4251PP(pp_leaveeval)
4252{
27da23d5 4253 dVAR; dSP;
a0d0e21e
LW		 4254 SV **newsp;
4255 PMOP *newpm;
4256 I32 gimme;
eb578fdb 4257 PERL_CONTEXT *cx;
a0d0e21e 4258 OP *retop;
06b5626a 4259 const U8 save_flags = PL_op -> op_flags;
a0d0e21e 4260 I32 optype;
b6494f15 4261 SV *namesv;
676a678a 4262 CV *evalcv;
a0d0e21e 4263
011c3814 4264 PERL_ASYNC_CHECK();
a0d0e21e
LW		 4265 POPBLOCK(cx,newpm);
4266 POPEVAL(cx);
b6494f15 4267 namesv = cx->blk_eval.old_namesv;
f39bc417 4268 retop = cx->blk_eval.retop;
676a678a 4269 evalcv = cx->blk_eval.cv;
a0d0e21e 4270
a1f49e72 4271 TAINT_NOT;
b9d76716
VP		 4272 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4273 gimme, SVs_TEMP);
3280af22 4274 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 4275
4fdae800 4276#ifdef DEBUGGING
676a678a 4277 assert(CvDEPTH(evalcv) == 1);
4fdae800 4278#endif
676a678a 4279 CvDEPTH(evalcv) = 0;
4fdae800 4280
1ce6579f 4281 if (optype == OP_REQUIRE &&
924508f0 4282 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 4283 {
1ce6579f 4284 /* Unassume the success we assumed earlier. */
b6494f15 4285 (void)hv_delete(GvHVn(PL_incgv),
ecad31f0 4286 SvPVX_const(namesv),
c60dbbc3 4287 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
b6494f15
VP		 4288 G_DISCARD);
4289 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4290 SVfARG(namesv));
c5df3096 4291 /* die_unwind() did LEAVE, or we won't be here */
f46d017c
GS		 4292 }
4293 else {
d343c3ef 4294 LEAVE_with_name("eval");
8433848b 4295 if (!(save_flags & OPf_SPECIAL)) {
ab69dbc2 4296 CLEAR_ERRSV();
8433848b 4297 }
a0d0e21e 4298 }
a0d0e21e
LW		 4299
4300 RETURNOP(retop);
4301}
4302
edb2152a
NC		 4303/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4304 close to the related Perl_create_eval_scope. */
4305void
4306Perl_delete_eval_scope(pTHX)
a0d0e21e 4307{
edb2152a
NC		 4308 SV **newsp;
4309 PMOP *newpm;
4310 I32 gimme;
eb578fdb 4311 PERL_CONTEXT *cx;
edb2152a
NC		 4312 I32 optype;
4313
4314 POPBLOCK(cx,newpm);
4315 POPEVAL(cx);
4316 PL_curpm = newpm;
d343c3ef 4317 LEAVE_with_name("eval_scope");
edb2152a
NC		 4318 PERL_UNUSED_VAR(newsp);
4319 PERL_UNUSED_VAR(gimme);
4320 PERL_UNUSED_VAR(optype);
4321}
a0d0e21e 4322
edb2152a
NC		 4323/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4324 also needed by Perl_fold_constants. */
4325PERL_CONTEXT *
4326Perl_create_eval_scope(pTHX_ U32 flags)
4327{
4328 PERL_CONTEXT *cx;
4329 const I32 gimme = GIMME_V;
4330
d343c3ef 4331 ENTER_with_name("eval_scope");
a0d0e21e
LW		 4332 SAVETMPS;
4333
edb2152a 4334 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
6b75f042 4335 PUSHEVAL(cx, 0);
a0d0e21e 4336
faef0170 4337 PL_in_eval = EVAL_INEVAL;
edb2152a
NC		 4338 if (flags & G_KEEPERR)
4339 PL_in_eval |= EVAL_KEEPERR;
ab69dbc2
RGS		 4340 else
4341 CLEAR_ERRSV();
edb2152a
NC		 4342 if (flags & G_FAKINGEVAL) {
4343 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4344 }
4345 return cx;
4346}
4347
4348PP(pp_entertry)
4349{
4350 dVAR;
df528165 4351 PERL_CONTEXT * const cx = create_eval_scope(0);
edb2152a 4352 cx->blk_eval.retop = cLOGOP->op_other->op_next;
533c011a 4353 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 4354}
4355
4356PP(pp_leavetry)
4357{
27da23d5 4358 dVAR; dSP;
a0d0e21e
LW		 4359 SV **newsp;
4360 PMOP *newpm;
4361 I32 gimme;
eb578fdb 4362 PERL_CONTEXT *cx;
a0d0e21e
LW		 4363 I32 optype;
4364
011c3814 4365 PERL_ASYNC_CHECK();
a0d0e21e
LW		 4366 POPBLOCK(cx,newpm);
4367 POPEVAL(cx);
9d4ba2ae 4368 PERL_UNUSED_VAR(optype);
a0d0e21e 4369
a1f49e72 4370 TAINT_NOT;
b9d76716 4371 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
3280af22 4372 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 4373
d343c3ef 4374 LEAVE_with_name("eval_scope");
ab69dbc2 4375 CLEAR_ERRSV();
745cf2ff 4376 RETURN;
a0d0e21e
LW		 4377}
4378
0d863452
RH		 4379PP(pp_entergiven)
4380{
4381 dVAR; dSP;
eb578fdb 4382 PERL_CONTEXT *cx;
0d863452
RH		 4383 const I32 gimme = GIMME_V;
4384
d343c3ef 4385 ENTER_with_name("given");
0d863452
RH		 4386 SAVETMPS;
4387
b5a64814
FC		 4388 if (PL_op->op_targ) {
4389 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4390 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4391 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4392 }
4393 else {
4394 SAVE_DEFSV;
4395 DEFSV_set(POPs);
4396 }
0d863452
RH		 4397
4398 PUSHBLOCK(cx, CXt_GIVEN, SP);
4399 PUSHGIVEN(cx);
4400
4401 RETURN;
4402}
4403
4404PP(pp_leavegiven)
4405{
4406 dVAR; dSP;
eb578fdb 4407 PERL_CONTEXT *cx;
0d863452
RH		 4408 I32 gimme;
4409 SV **newsp;
4410 PMOP *newpm;
96a5add6 4411 PERL_UNUSED_CONTEXT;
0d863452
RH		 4412
4413 POPBLOCK(cx,newpm);
4414 assert(CxTYPE(cx) == CXt_GIVEN);
0d863452 4415
25b991bf 4416 TAINT_NOT;
b9d76716 4417 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
25b991bf 4418 PL_curpm = newpm; /* Don't pop $1 et al till now */
0d863452 4419
d343c3ef 4420 LEAVE_with_name("given");
25b991bf 4421 RETURN;
0d863452
RH		 4422}
4423
4424/* Helper routines used by pp_smartmatch */
4136a0f7 4425STATIC PMOP *
84679df5 4426S_make_matcher(pTHX_ REGEXP *re)
0d863452 4427{
97aff369 4428 dVAR;
0d863452 4429 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
7918f24d
NC		 4430
4431 PERL_ARGS_ASSERT_MAKE_MATCHER;
4432
d6106309 4433 PM_SETRE(matcher, ReREFCNT_inc(re));
7918f24d 4434
0d863452 4435 SAVEFREEOP((OP *) matcher);
d343c3ef 4436 ENTER_with_name("matcher"); SAVETMPS;
0d863452
RH		 4437 SAVEOP();
4438 return matcher;
4439}
4440
4136a0f7 4441STATIC bool
0d863452
RH		 4442S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4443{
97aff369 4444 dVAR;
0d863452 4445 dSP;
7918f24d
NC		 4446
4447 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
0d863452
RH		 4448
4449 PL_op = (OP *) matcher;
4450 XPUSHs(sv);
4451 PUTBACK;
897d3989 4452 (void) Perl_pp_match(aTHX);
0d863452
RH		 4453 SPAGAIN;
4454 return (SvTRUEx(POPs));
4455}
4456
4136a0f7 4457STATIC void
0d863452
RH		 4458S_destroy_matcher(pTHX_ PMOP *matcher)
4459{
97aff369 4460 dVAR;
7918f24d
NC		 4461
4462 PERL_ARGS_ASSERT_DESTROY_MATCHER;
0d863452 4463 PERL_UNUSED_ARG(matcher);
7918f24d 4464
0d863452 4465 FREETMPS;
d343c3ef 4466 LEAVE_with_name("matcher");
0d863452
RH		 4467}
4468
4469/* Do a smart match */
4470PP(pp_smartmatch)
4471{
d7c0d282 4472 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
be88a5c3 4473 return do_smartmatch(NULL, NULL, 0);
0d863452
RH		 4474}
4475
4b021f5f
RGS		 4476/* This version of do_smartmatch() implements the
4477 * table of smart matches that is found in perlsyn.
0d863452 4478 */
4136a0f7 4479STATIC OP *
be88a5c3 4480S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
0d863452 4481{
97aff369 4482 dVAR;
0d863452
RH		 4483 dSP;
4484
41e726ac 4485 bool object_on_left = FALSE;
0d863452
RH		 4486 SV *e = TOPs; /* e is for 'expression' */
4487 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
a566f585 4488
6f1401dc
DM		 4489 /* Take care only to invoke mg_get() once for each argument.
4490 * Currently we do this by copying the SV if it's magical. */
4491 if (d) {
be88a5c3 4492 if (!copied && SvGMAGICAL(d))
6f1401dc
DM		 4493 d = sv_mortalcopy(d);
4494 }
4495 else
4496 d = &PL_sv_undef;
4497
4498 assert(e);
4499 if (SvGMAGICAL(e))
4500 e = sv_mortalcopy(e);
4501
2c9d2554 4502 /* First of all, handle overload magic of the rightmost argument */
6d743019 4503 if (SvAMAGIC(e)) {
d7c0d282
DM		 4504 SV * tmpsv;
4505 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4506 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4507
b900a653 4508 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
7c41e62e
RGS		 4509 if (tmpsv) {
4510 SPAGAIN;
4511 (void)POPs;
4512 SETs(tmpsv);
4513 RETURN;
4514 }
d7c0d282 4515 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
7c41e62e 4516 }
62ec5f58 4517
0d863452
RH		 4518 SP -= 2; /* Pop the values */
4519
0d863452 4520
b0138e99 4521 /* ~~ undef */
62ec5f58 4522 if (!SvOK(e)) {
d7c0d282 4523 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
62ec5f58 4524 if (SvOK(d))
33570f8b
RGS		 4525 RETPUSHNO;
4526 else
62ec5f58 4527 RETPUSHYES;
33570f8b 4528 }
e67b97bd 4529
d7c0d282
DM		 4530 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4531 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
62ec5f58 4532 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
d7c0d282 4533 }
41e726ac
RGS		 4534 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4535 object_on_left = TRUE;
62ec5f58 4536
b0138e99 4537 /* ~~ sub */
a4a197da 4538 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
0d863452 4539 I32 c;
41e726ac
RGS		 4540 if (object_on_left) {
4541 goto sm_any_sub; /* Treat objects like scalars */
4542 }
4543 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
a4a197da
RGS		 4544 /* Test sub truth for each key */
4545 HE *he;
4546 bool andedresults = TRUE;
4547 HV *hv = (HV*) SvRV(d);
168ff818 4548 I32 numkeys = hv_iterinit(hv);
d7c0d282 4549 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
168ff818 4550 if (numkeys == 0)
07edf497 4551 RETPUSHYES;
a4a197da 4552 while ( (he = hv_iternext(hv)) ) {
d7c0d282 4553 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
d343c3ef 4554 ENTER_with_name("smartmatch_hash_key_test");
a4a197da
RGS		 4555 SAVETMPS;
4556 PUSHMARK(SP);
4557 PUSHs(hv_iterkeysv(he));
4558 PUTBACK;
4559 c = call_sv(e, G_SCALAR);
4560 SPAGAIN;
4561 if (c == 0)
4562 andedresults = FALSE;
4563 else
4564 andedresults = SvTRUEx(POPs) && andedresults;
4565 FREETMPS;
d343c3ef 4566 LEAVE_with_name("smartmatch_hash_key_test");
a4a197da
RGS		 4567 }
4568 if (andedresults)
4569 RETPUSHYES;
4570 else
4571 RETPUSHNO;
4572 }
4573 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4574 /* Test sub truth for each element */
4575 I32 i;
4576 bool andedresults = TRUE;
4577 AV *av = (AV*) SvRV(d);
4578 const I32 len = av_len(av);
d7c0d282 4579 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
168ff818 4580 if (len == -1)
07edf497 4581 RETPUSHYES;
a4a197da
RGS		 4582 for (i = 0; i <= len; ++i) {
4583 SV * const * const svp = av_fetch(av, i, FALSE);
d7c0d282 4584 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
d343c3ef 4585 ENTER_with_name("smartmatch_array_elem_test");
a4a197da
RGS		 4586 SAVETMPS;
4587 PUSHMARK(SP);
4588 if (svp)
4589 PUSHs(*svp);
4590 PUTBACK;
4591 c = call_sv(e, G_SCALAR);
4592 SPAGAIN;
4593 if (c == 0)
4594 andedresults = FALSE;
4595 else
4596 andedresults = SvTRUEx(POPs) && andedresults;
4597 FREETMPS;
d343c3ef 4598 LEAVE_with_name("smartmatch_array_elem_test");
a4a197da
RGS		 4599 }
4600 if (andedresults)
4601 RETPUSHYES;
4602 else
4603 RETPUSHNO;
4604 }
4605 else {
41e726ac 4606 sm_any_sub:
d7c0d282 4607 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
d343c3ef 4608 ENTER_with_name("smartmatch_coderef");
a4a197da
RGS		 4609 SAVETMPS;
4610 PUSHMARK(SP);
4611 PUSHs(d);
4612 PUTBACK;
4613 c = call_sv(e, G_SCALAR);
4614 SPAGAIN;
4615 if (c == 0)
4616 PUSHs(&PL_sv_no);
4617 else if (SvTEMP(TOPs))
4618 SvREFCNT_inc_void(TOPs);
4619 FREETMPS;
d343c3ef 4620 LEAVE_with_name("smartmatch_coderef");
a4a197da
RGS		 4621 RETURN;
4622 }
0d863452 4623 }
b0138e99 4624 /* ~~ %hash */
61a621c6 4625 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
41e726ac
RGS		 4626 if (object_on_left) {
4627 goto sm_any_hash; /* Treat objects like scalars */
4628 }
4629 else if (!SvOK(d)) {
d7c0d282 4630 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
61a621c6
RGS		 4631 RETPUSHNO;
4632 }
4633 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
0d863452
RH		 4634 /* Check that the key-sets are identical */
4635 HE *he;
61a621c6 4636 HV *other_hv = MUTABLE_HV(SvRV(d));
0d863452
RH		 4637 bool tied = FALSE;
4638 bool other_tied = FALSE;
4639 U32 this_key_count = 0,
4640 other_key_count = 0;
33ed63a2 4641 HV *hv = MUTABLE_HV(SvRV(e));
d7c0d282
DM		 4642
4643 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
0d863452 4644 /* Tied hashes don't know how many keys they have. */
33ed63a2 4645 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
0d863452
RH		 4646 tied = TRUE;
4647 }
ad64d0ec 4648 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
c445ea15 4649 HV * const temp = other_hv;
33ed63a2
RGS		 4650 other_hv = hv;
4651 hv = temp;
0d863452
RH		 4652 tied = TRUE;
4653 }
ad64d0ec 4654 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
0d863452
RH		 4655 other_tied = TRUE;
4656
33ed63a2 4657 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
0d863452
RH		 4658 RETPUSHNO;
4659
4660 /* The hashes have the same number of keys, so it suffices
4661 to check that one is a subset of the other. */
33ed63a2
RGS		 4662 (void) hv_iterinit(hv);
4663 while ( (he = hv_iternext(hv)) ) {
b15feb55 4664 SV *key = hv_iterkeysv(he);
d7c0d282
DM		 4665
4666 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
0d863452
RH		 4667 ++ this_key_count;
4668
b15feb55 4669 if(!hv_exists_ent(other_hv, key, 0)) {
33ed63a2 4670 (void) hv_iterinit(hv); /* reset iterator */
0d863452
RH		 4671 RETPUSHNO;
4672 }
4673 }
4674
4675 if (other_tied) {
4676 (void) hv_iterinit(other_hv);
4677 while ( hv_iternext(other_hv) )
4678 ++other_key_count;
4679 }
4680 else
4681 other_key_count = HvUSEDKEYS(other_hv);
4682
4683 if (this_key_count != other_key_count)
4684 RETPUSHNO;
4685 else
4686 RETPUSHYES;
4687 }
61a621c6
RGS		 4688 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4689 AV * const other_av = MUTABLE_AV(SvRV(d));
c445ea15 4690 const I32 other_len = av_len(other_av) + 1;
0d863452 4691 I32 i;
33ed63a2 4692 HV *hv = MUTABLE_HV(SvRV(e));
71b0fb34 4693
d7c0d282 4694 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
71b0fb34 4695 for (i = 0; i < other_len; ++i) {
c445ea15 4696 SV ** const svp = av_fetch(other_av, i, FALSE);
d7c0d282 4697 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
71b0fb34 4698 if (svp) { /* ??? When can this not happen? */
b15feb55 4699 if (hv_exists_ent(hv, *svp, 0))
71b0fb34
DK		 4700 RETPUSHYES;
4701 }
0d863452 4702 }
71b0fb34 4703 RETPUSHNO;
0d863452 4704 }
a566f585 4705 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
d7c0d282 4706 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
ea0c2dbd
RGS		 4707 sm_regex_hash:
4708 {
4709 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4710 HE *he;
4711 HV *hv = MUTABLE_HV(SvRV(e));
4712
4713 (void) hv_iterinit(hv);
4714 while ( (he = hv_iternext(hv)) ) {
d7c0d282 4715 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
ea0c2dbd
RGS		 4716 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4717 (void) hv_iterinit(hv);
4718 destroy_matcher(matcher);
4719 RETPUSHYES;
4720 }
0d863452 4721 }
ea0c2dbd
RGS		 4722 destroy_matcher(matcher);
4723 RETPUSHNO;
0d863452 4724 }
0d863452
RH		 4725 }
4726 else {
41e726ac 4727 sm_any_hash:
d7c0d282 4728 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
61a621c6 4729 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
0d863452
RH		 4730 RETPUSHYES;
4731 else
4732 RETPUSHNO;
4733 }
4734 }
b0138e99
RGS		 4735 /* ~~ @array */
4736 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
41e726ac
RGS		 4737 if (object_on_left) {
4738 goto sm_any_array; /* Treat objects like scalars */
4739 }
4740 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
b0138e99
RGS		 4741 AV * const other_av = MUTABLE_AV(SvRV(e));
4742 const I32 other_len = av_len(other_av) + 1;
4743 I32 i;
4744
d7c0d282 4745 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
b0138e99
RGS		 4746 for (i = 0; i < other_len; ++i) {
4747 SV ** const svp = av_fetch(other_av, i, FALSE);
d7c0d282
DM		 4748
4749 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
b0138e99 4750 if (svp) { /* ??? When can this not happen? */
b15feb55 4751 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
b0138e99
RGS		 4752 RETPUSHYES;
4753 }
4754 }
4755 RETPUSHNO;
4756 }
4757 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4758 AV *other_av = MUTABLE_AV(SvRV(d));
d7c0d282 4759 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
b0138e99 4760 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
0d863452
RH		 4761 RETPUSHNO;
4762 else {
4763 I32 i;
c445ea15 4764 const I32 other_len = av_len(other_av);
0d863452 4765
a0714e2c 4766 if (NULL == seen_this) {
0d863452 4767 seen_this = newHV();
ad64d0ec 4768 (void) sv_2mortal(MUTABLE_SV(seen_this));
0d863452 4769 }
a0714e2c 4770 if (NULL == seen_other) {
6bc991bf 4771 seen_other = newHV();
ad64d0ec 4772 (void) sv_2mortal(MUTABLE_SV(seen_other));
0d863452
RH		 4773 }
4774 for(i = 0; i <= other_len; ++i) {
b0138e99 4775 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
c445ea15
AL		 4776 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4777
0d863452 4778 if (!this_elem || !other_elem) {
69c3dccf
RGS		 4779 if ((this_elem && SvOK(*this_elem))
4780 || (other_elem && SvOK(*other_elem)))
0d863452
RH		 4781 RETPUSHNO;
4782 }
365c4e3d
RGS		 4783 else if (hv_exists_ent(seen_this,
4784 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4785 hv_exists_ent(seen_other,
4786 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
0d863452
RH		 4787 {
4788 if (*this_elem != *other_elem)
4789 RETPUSHNO;
4790 }
4791 else {
04fe65b0
RGS		 4792 (void)hv_store_ent(seen_this,
4793 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4794 &PL_sv_undef, 0);
4795 (void)hv_store_ent(seen_other,
4796 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4797 &PL_sv_undef, 0);
0d863452 4798 PUSHs(*other_elem);
a566f585 4799 PUSHs(*this_elem);
0d863452
RH		 4800
4801 PUTBACK;
d7c0d282 4802 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
be88a5c3 4803 (void) do_smartmatch(seen_this, seen_other, 0);
0d863452 4804 SPAGAIN;
d7c0d282 4805 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
0d863452
RH		 4806
4807 if (!SvTRUEx(POPs))
4808 RETPUSHNO;
4809 }
4810 }
4811 RETPUSHYES;
4812 }
4813 }
a566f585 4814 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
d7c0d282 4815 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
ea0c2dbd
RGS		 4816 sm_regex_array:
4817 {
4818 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4819 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4820 I32 i;
0d863452 4821
ea0c2dbd
RGS		 4822 for(i = 0; i <= this_len; ++i) {
4823 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
d7c0d282 4824 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
ea0c2dbd
RGS		 4825 if (svp && matcher_matches_sv(matcher, *svp)) {
4826 destroy_matcher(matcher);
4827 RETPUSHYES;
4828 }
0d863452 4829 }
ea0c2dbd
RGS		 4830 destroy_matcher(matcher);
4831 RETPUSHNO;
0d863452 4832 }
0d863452 4833 }
015eb7b9
RGS		 4834 else if (!SvOK(d)) {
4835 /* undef ~~ array */
4836 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
0d863452
RH		 4837 I32 i;
4838
d7c0d282 4839 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
015eb7b9 4840 for (i = 0; i <= this_len; ++i) {
b0138e99 4841 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
d7c0d282 4842 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
015eb7b9 4843 if (!svp || !SvOK(*svp))
0d863452
RH		 4844 RETPUSHYES;
4845 }
4846 RETPUSHNO;
4847 }
015eb7b9 4848 else {
41e726ac
RGS		 4849 sm_any_array:
4850 {
4851 I32 i;
4852 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
0d863452 4853
d7c0d282 4854 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
41e726ac
RGS		 4855 for (i = 0; i <= this_len; ++i) {
4856 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4857 if (!svp)
4858 continue;
015eb7b9 4859
41e726ac
RGS		 4860 PUSHs(d);
4861 PUSHs(*svp);
4862 PUTBACK;
4863 /* infinite recursion isn't supposed to happen here */
d7c0d282 4864 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
be88a5c3 4865 (void) do_smartmatch(NULL, NULL, 1);
41e726ac 4866 SPAGAIN;
d7c0d282 4867 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
41e726ac
RGS		 4868 if (SvTRUEx(POPs))
4869 RETPUSHYES;
4870 }
4871 RETPUSHNO;
0d863452 4872 }
0d863452
RH		 4873 }
4874 }
b0138e99 4875 /* ~~ qr// */
a566f585 4876 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
ea0c2dbd
RGS		 4877 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4878 SV *t = d; d = e; e = t;
d7c0d282 4879 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
ea0c2dbd
RGS		 4880 goto sm_regex_hash;
4881 }
4882 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4883 SV *t = d; d = e; e = t;
d7c0d282 4884 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
ea0c2dbd
RGS		 4885 goto sm_regex_array;
4886 }
4887 else {
4888 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
0d863452 4889
d7c0d282 4890 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
ea0c2dbd
RGS		 4891 PUTBACK;
4892 PUSHs(matcher_matches_sv(matcher, d)
4893 ? &PL_sv_yes
4894 : &PL_sv_no);
4895 destroy_matcher(matcher);
4896 RETURN;
4897 }
0d863452 4898 }
b0138e99 4899 /* ~~ scalar */
2c9d2554
RGS		 4900 /* See if there is overload magic on left */
4901 else if (object_on_left && SvAMAGIC(d)) {
4902 SV *tmpsv;
d7c0d282
DM		 4903 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4904 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
2c9d2554
RGS		 4905 PUSHs(d); PUSHs(e);
4906 PUTBACK;
4907 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4908 if (tmpsv) {
4909 SPAGAIN;
4910 (void)POPs;
4911 SETs(tmpsv);
4912 RETURN;
4913 }
4914 SP -= 2;
d7c0d282 4915 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
2c9d2554
RGS		 4916 goto sm_any_scalar;
4917 }
fb51372e
RGS		 4918 else if (!SvOK(d)) {
4919 /* undef ~~ scalar ; we already know that the scalar is SvOK */
d7c0d282 4920 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
fb51372e
RGS		 4921 RETPUSHNO;
4922 }
2c9d2554
RGS		 4923 else
4924 sm_any_scalar:
4925 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
d7c0d282
DM		 4926 DEBUG_M(if (SvNIOK(e))
4927 Perl_deb(aTHX_ " applying rule Any-Num\n");
4928 else
4929 Perl_deb(aTHX_ " applying rule Num-numish\n");
4930 );
33ed63a2 4931 /* numeric comparison */
0d863452
RH		 4932 PUSHs(d); PUSHs(e);
4933 PUTBACK;
a98fe34d 4934 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
897d3989 4935 (void) Perl_pp_i_eq(aTHX);
0d863452 4936 else
897d3989 4937 (void) Perl_pp_eq(aTHX);
0d863452
RH		 4938 SPAGAIN;
4939 if (SvTRUEx(POPs))
4940 RETPUSHYES;
4941 else
4942 RETPUSHNO;
4943 }
4944
4945 /* As a last resort, use string comparison */
d7c0d282 4946 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
0d863452
RH		 4947 PUSHs(d); PUSHs(e);
4948 PUTBACK;
897d3989 4949 return Perl_pp_seq(aTHX);
0d863452
RH		 4950}
4951
4952PP(pp_enterwhen)
4953{
4954 dVAR; dSP;
eb578fdb 4955 PERL_CONTEXT *cx;
0d863452
RH		 4956 const I32 gimme = GIMME_V;
4957
4958 /* This is essentially an optimization: if the match
4959 fails, we don't want to push a context and then
4960 pop it again right away, so we skip straight
4961 to the op that follows the leavewhen.
25b991bf 4962 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
0d863452
RH		 4963 */
4964 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
25b991bf 4965 RETURNOP(cLOGOP->op_other->op_next);
0d863452 4966
c08f093b 4967 ENTER_with_name("when");
0d863452
RH		 4968 SAVETMPS;
4969
4970 PUSHBLOCK(cx, CXt_WHEN, SP);
4971 PUSHWHEN(cx);
4972
4973 RETURN;
4974}
4975
4976PP(pp_leavewhen)
4977{
4978 dVAR; dSP;
c08f093b 4979 I32 cxix;
eb578fdb 4980 PERL_CONTEXT *cx;
c08f093b 4981 I32 gimme;
0d863452
RH		 4982 SV **newsp;
4983 PMOP *newpm;
4984
c08f093b
VP		 4985 cxix = dopoptogiven(cxstack_ix);
4986 if (cxix < 0)
fc7debfb
FC		 4987 /* diag_listed_as: Can't "when" outside a topicalizer */
4988 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4989 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
c08f093b 4990
0d863452
RH		 4991 POPBLOCK(cx,newpm);
4992 assert(CxTYPE(cx) == CXt_WHEN);
4993
c08f093b
VP		 4994 TAINT_NOT;
4995 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
0d863452
RH		 4996 PL_curpm = newpm; /* pop $1 et al */
4997
c08f093b
VP		 4998 LEAVE_with_name("when");
4999
5000 if (cxix < cxstack_ix)
5001 dounwind(cxix);
5002
5003 cx = &cxstack[cxix];
5004
5005 if (CxFOREACH(cx)) {
5006 /* clear off anything above the scope we're re-entering */
5007 I32 inner = PL_scopestack_ix;
5008
5009 TOPBLOCK(cx);
5010 if (PL_scopestack_ix < inner)
5011 leave_scope(PL_scopestack[PL_scopestack_ix]);
5012 PL_curcop = cx->blk_oldcop;
5013
47c9d59f 5014 PERL_ASYNC_CHECK();
c08f093b
VP		 5015 return cx->blk_loop.my_op->op_nextop;
5016 }
47c9d59f
NC		 5017 else {
5018 PERL_ASYNC_CHECK();
b1b5a4ae 5019 RETURNOP(cx->blk_givwhen.leave_op);
47c9d59f 5020 }
0d863452
RH		 5021}
5022
5023PP(pp_continue)
5024{
c08f093b 5025 dVAR; dSP;
0d863452 5026 I32 cxix;
eb578fdb 5027 PERL_CONTEXT *cx;
c08f093b
VP		 5028 I32 gimme;
5029 SV **newsp;
5030 PMOP *newpm;
7be5bd17
FR		 5031
5032 PERL_UNUSED_VAR(gimme);
0d863452
RH		 5033
5034 cxix = dopoptowhen(cxstack_ix);
5035 if (cxix < 0)
5036 DIE(aTHX_ "Can't \"continue\" outside a when block");
c08f093b 5037
0d863452
RH		 5038 if (cxix < cxstack_ix)
5039 dounwind(cxix);
5040
c08f093b
VP		 5041 POPBLOCK(cx,newpm);
5042 assert(CxTYPE(cx) == CXt_WHEN);
5043
5044 SP = newsp;
5045 PL_curpm = newpm; /* pop $1 et al */
5046
5047 LEAVE_with_name("when");
5048 RETURNOP(cx->blk_givwhen.leave_op->op_next);
0d863452
RH		 5049}
5050
5051PP(pp_break)
5052{
5053 dVAR;
5054 I32 cxix;
eb578fdb 5055 PERL_CONTEXT *cx;
25b991bf 5056
0d863452 5057 cxix = dopoptogiven(cxstack_ix);
c08f093b
VP		 5058 if (cxix < 0)
5059 DIE(aTHX_ "Can't \"break\" outside a given block");
5060
5061 cx = &cxstack[cxix];
5062 if (CxFOREACH(cx))
0d863452
RH		 5063 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5064
5065 if (cxix < cxstack_ix)
5066 dounwind(cxix);
0d863452 5067
0787ea8a
VP		 5068 /* Restore the sp at the time we entered the given block */
5069 TOPBLOCK(cx);
5070
c08f093b 5071 return cx->blk_givwhen.leave_op;
0d863452
RH		 5072}
5073
74e0ddf7 5074static MAGIC *
cea2e8a9 5075S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 5076{
5077 STRLEN len;
eb578fdb
KW		 5078 char *s = SvPV(sv, len);
5079 char *send;
5080 char *base = NULL; /* start of current field */
5081 I32 skipspaces = 0; /* number of contiguous spaces seen */
086b26f3
DM		 5082 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5083 bool repeat = FALSE; /* ~~ seen on this line */
5084 bool postspace = FALSE; /* a text field may need right padding */
dea28490 5085 U32 *fops;
eb578fdb 5086 U32 *fpc;
086b26f3 5087 U32 *linepc = NULL; /* position of last FF_LINEMARK */
eb578fdb 5088 I32 arg;
086b26f3
DM		 5089 bool ischop; /* it's a ^ rather than a @ */
5090 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
a1b95068 5091 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3808a683
DM		 5092 MAGIC *mg = NULL;
5093 SV *sv_copy;
a0d0e21e 5094
7918f24d
NC		 5095 PERL_ARGS_ASSERT_DOPARSEFORM;
5096
55497cff 5097 if (len == 0)
cea2e8a9 5098 Perl_croak(aTHX_ "Null picture in formline");
ac27b0f5 5099
3808a683
DM		 5100 if (SvTYPE(sv) >= SVt_PVMG) {
5101 /* This might, of course, still return NULL. */
5102 mg = mg_find(sv, PERL_MAGIC_fm);
5103 } else {
5104 sv_upgrade(sv, SVt_PVMG);
5105 }
5106
5107 if (mg) {
5108 /* still the same as previously-compiled string? */
5109 SV *old = mg->mg_obj;
5110 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5111 && len == SvCUR(old)
5112 && strnEQ(SvPVX(old), SvPVX(sv), len)
b57b1734
DM		 5113 ) {
5114 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
3808a683 5115 return mg;
b57b1734 5116 }
3808a683 5117
b57b1734 5118 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
3808a683
DM		 5119 Safefree(mg->mg_ptr);
5120 mg->mg_ptr = NULL;
5121 SvREFCNT_dec(old);
5122 mg->mg_obj = NULL;
5123 }
b57b1734
DM		 5124 else {
5125 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
3808a683 5126 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
b57b1734 5127 }
3808a683
DM		 5128
5129 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5130 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5131 send = s + len;
5132
5133
815f25c6
DM		 5134 /* estimate the buffer size needed */
5135 for (base = s; s <= send; s++) {
a1b95068 5136 if (*s == '\n' || *s == '@' || *s == '^')
815f25c6
DM		 5137 maxops += 10;
5138 }
5139 s = base;
c445ea15 5140 base = NULL;
815f25c6 5141
a02a5408 5142 Newx(fops, maxops, U32);
a0d0e21e
LW		 5143 fpc = fops;
5144
5145 if (s < send) {
5146 linepc = fpc;
5147 *fpc++ = FF_LINEMARK;
5148 noblank = repeat = FALSE;
5149 base = s;
5150 }
5151
5152 while (s <= send) {
5153 switch (*s++) {
5154 default:
5155 skipspaces = 0;
5156 continue;
5157
5158 case '~':
5159 if (*s == '~') {
5160 repeat = TRUE;
b57b1734
DM		 5161 skipspaces++;
5162 s++;
a0d0e21e
LW		 5163 }
5164 noblank = TRUE;
a0d0e21e
LW		 5165 /* FALL THROUGH */
5166 case ' ': case '\t':
5167 skipspaces++;
5168 continue;
a1b95068
WL		 5169 case 0:
5170 if (s < send) {
5171 skipspaces = 0;
5172 continue;
5173 } /* else FALL THROUGH */
5174 case '\n':
a0d0e21e
LW		 5175 arg = s - base;
5176 skipspaces++;
5177 arg -= skipspaces;
5178 if (arg) {
5f05dabc 5179 if (postspace)
a0d0e21e 5180 *fpc++ = FF_SPACE;
a0d0e21e 5181 *fpc++ = FF_LITERAL;
76912796 5182 *fpc++ = (U32)arg;
a0d0e21e 5183 }
5f05dabc 5184 postspace = FALSE;
a0d0e21e
LW		 5185 if (s <= send)
5186 skipspaces--;
5187 if (skipspaces) {
5188 *fpc++ = FF_SKIP;
76912796 5189 *fpc++ = (U32)skipspaces;
a0d0e21e
LW		 5190 }
5191 skipspaces = 0;
5192 if (s <= send)
5193 *fpc++ = FF_NEWLINE;
5194 if (noblank) {
5195 *fpc++ = FF_BLANK;
5196 if (repeat)
5197 arg = fpc - linepc + 1;
5198 else
5199 arg = 0;
76912796 5200 *fpc++ = (U32)arg;
a0d0e21e
LW		 5201 }
5202 if (s < send) {
5203 linepc = fpc;
5204 *fpc++ = FF_LINEMARK;
5205 noblank = repeat = FALSE;
5206 base = s;
5207 }
5208 else
5209 s++;
5210 continue;
5211
5212 case '@':
5213 case '^':
5214 ischop = s[-1] == '^';
5215
5216 if (postspace) {
5217 *fpc++ = FF_SPACE;
5218 postspace = FALSE;
5219 }
5220 arg = (s - base) - 1;
5221 if (arg) {
5222 *fpc++ = FF_LITERAL;
76912796 5223 *fpc++ = (U32)arg;
a0d0e21e
LW		 5224 }
5225
5226 base = s - 1;
5227 *fpc++ = FF_FETCH;
086b26f3 5228 if (*s == '*') { /* @* or ^* */
a0d0e21e 5229 s++;
a1b95068
WL		 5230 *fpc++ = 2; /* skip the @* or ^* */
5231 if (ischop) {
5232 *fpc++ = FF_LINESNGL;
5233 *fpc++ = FF_CHOP;
5234 } else
5235 *fpc++ = FF_LINEGLOB;
a0d0e21e 5236 }
086b26f3 5237 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
a701009a 5238 arg = ischop ? FORM_NUM_BLANK : 0;
a0d0e21e
LW		 5239 base = s - 1;
5240 while (*s == '#')
5241 s++;
5242 if (*s == '.') {
06b5626a 5243 const char * const f = ++s;
a0d0e21e
LW		 5244 while (*s == '#')
5245 s++;
a701009a 5246 arg |= FORM_NUM_POINT + (s - f);
a0d0e21e
LW		 5247 }
5248 *fpc++ = s - base; /* fieldsize for FETCH */
5249 *fpc++ = FF_DECIMAL;
76912796 5250 *fpc++ = (U32)arg;
a1b95068 5251 unchopnum |= ! ischop;
784707d5
JP		 5252 }
5253 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
a701009a 5254 arg = ischop ? FORM_NUM_BLANK : 0;
784707d5
JP		 5255 base = s - 1;
5256 s++; /* skip the '0' first */
5257 while (*s == '#')
5258 s++;
5259 if (*s == '.') {
06b5626a 5260 const char * const f = ++s;
784707d5
JP		 5261 while (*s == '#')
5262 s++;
a701009a 5263 arg |= FORM_NUM_POINT + (s - f);
784707d5
JP		 5264 }
5265 *fpc++ = s - base; /* fieldsize for FETCH */
5266 *fpc++ = FF_0DECIMAL;
76912796 5267 *fpc++ = (U32)arg;
a1b95068 5268 unchopnum |= ! ischop;
a0d0e21e 5269 }
086b26f3 5270 else { /* text field */
a0d0e21e
LW		 5271 I32 prespace = 0;
5272 bool ismore = FALSE;
5273
5274 if (*s == '>') {
5275 while (*++s == '>') ;
5276 prespace = FF_SPACE;
5277 }
5278 else if (*s == '|') {
5279 while (*++s == '|') ;
5280 prespace = FF_HALFSPACE;
5281 postspace = TRUE;
5282 }
5283 else {
5284 if (*s == '<')
5285 while (*++s == '<') ;
5286 postspace = TRUE;
5287 }
5288 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5289 s += 3;
5290 ismore = TRUE;
5291 }
5292 *fpc++ = s - base; /* fieldsize for FETCH */
5293
5294 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5295
5296 if (prespace)
76912796 5297 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
a0d0e21e
LW		 5298 *fpc++ = FF_ITEM;
5299 if (ismore)
5300 *fpc++ = FF_MORE;
5301 if (ischop)
5302 *fpc++ = FF_CHOP;
5303 }
5304 base = s;
5305 skipspaces = 0;
5306 continue;
5307 }
5308 }
5309 *fpc++ = FF_END;
5310
815f25c6 5311 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
a0d0e21e 5312 arg = fpc - fops;
74e0ddf7 5313
3808a683 5314 mg->mg_ptr = (char *) fops;
74e0ddf7 5315 mg->mg_len = arg * sizeof(U32);
3808a683
DM		 5316 mg->mg_obj = sv_copy;
5317 mg->mg_flags |= MGf_REFCOUNTED;
a1b95068 5318
bfed75c6 5319 if (unchopnum && repeat)
75f63940 5320 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
74e0ddf7
NC		 5321
5322 return mg;
a1b95068
WL		 5323}
5324
5325
5326STATIC bool
5327S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5328{
5329 /* Can value be printed in fldsize chars, using %*.*f ? */
5330 NV pwr = 1;
5331 NV eps = 0.5;
5332 bool res = FALSE;
5333 int intsize = fldsize - (value < 0 ? 1 : 0);
5334
a701009a 5335 if (frcsize & FORM_NUM_POINT)
a1b95068 5336 intsize--;
a701009a 5337 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
a1b95068
WL		 5338 intsize -= frcsize;
5339
5340 while (intsize--) pwr *= 10.0;
5341 while (frcsize--) eps /= 10.0;
5342
5343 if( value >= 0 ){
5344 if (value + eps >= pwr)
5345 res = TRUE;
5346 } else {
5347 if (value - eps <= -pwr)
5348 res = TRUE;
5349 }
5350 return res;
a0d0e21e 5351}
4e35701f 5352
bbed91b5 5353static I32
0bd48802 5354S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
bbed91b5 5355{
27da23d5 5356 dVAR;
0bd48802 5357 SV * const datasv = FILTER_DATA(idx);
504618e9 5358 const int filter_has_file = IoLINES(datasv);
ad64d0ec
NC		 5359 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5360 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
941a98a0 5361 int status = 0;
ec0b63d7 5362 SV *upstream;
941a98a0 5363 STRLEN got_len;
162177c1
Z		 5364 char *got_p = NULL;
5365 char *prune_from = NULL;
34113e50 5366 bool read_from_cache = FALSE;
bb7a0f54 5367 STRLEN umaxlen;
d60d2019 5368 SV *err = NULL;
bb7a0f54 5369
7918f24d
NC		 5370 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5371
bb7a0f54
MHM		 5372 assert(maxlen >= 0);
5373 umaxlen = maxlen;
5675696b 5374
bbed91b5
KF		 5375 /* I was having segfault trouble under Linux 2.2.5 after a
5376 parse error occured. (Had to hack around it with a test
13765c85 5377 for PL_parser->error_count == 0.) Solaris doesn't segfault --
bbed91b5
KF		 5378 not sure where the trouble is yet. XXX */
5379
4464f08e
NC		 5380 {
5381 SV *const cache = datasv;
937b367d
NC		 5382 if (SvOK(cache)) {
5383 STRLEN cache_len;
5384 const char *cache_p = SvPV(cache, cache_len);
941a98a0
NC		 5385 STRLEN take = 0;
5386
bb7a0f54 5387 if (umaxlen) {
941a98a0
NC		 5388 /* Running in block mode and we have some cached data already.
5389 */
bb7a0f54 5390 if (cache_len >= umaxlen) {
941a98a0
NC		 5391 /* In fact, so much data we don't even need to call
5392 filter_read. */
bb7a0f54 5393 take = umaxlen;
941a98a0
NC		 5394 }
5395 } else {
10edeb5d
JH		 5396 const char *const first_nl =
5397 (const char *)memchr(cache_p, '\n', cache_len);
941a98a0
NC		 5398 if (first_nl) {
5399 take = first_nl + 1 - cache_p;
5400 }
5401 }
5402 if (take) {
5403 sv_catpvn(buf_sv, cache_p, take);
5404 sv_chop(cache, cache_p + take);
486ec47a 5405 /* Definitely not EOF */
937b367d
NC		 5406 return 1;
5407 }
941a98a0 5408
937b367d 5409 sv_catsv(buf_sv, cache);
bb7a0f54
MHM		 5410 if (umaxlen) {
5411 umaxlen -= cache_len;
941a98a0 5412 }
937b367d 5413 SvOK_off(cache);
34113e50 5414 read_from_cache = TRUE;
937b367d
NC		 5415 }
5416 }
ec0b63d7 5417
34113e50
NC		 5418 /* Filter API says that the filter appends to the contents of the buffer.
5419 Usually the buffer is "", so the details don't matter. But if it's not,
5420 then clearly what it contains is already filtered by this filter, so we
5421 don't want to pass it in a second time.
5422 I'm going to use a mortal in case the upstream filter croaks. */
ec0b63d7
NC		 5423 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5424 ? sv_newmortal() : buf_sv;
5425 SvUPGRADE(upstream, SVt_PV);
937b367d 5426
bbed91b5 5427 if (filter_has_file) {
67e70b33 5428 status = FILTER_READ(idx+1, upstream, 0);
bbed91b5
KF		 5429 }
5430
34113e50 5431 if (filter_sub && status >= 0) {
39644a26 5432 dSP;
bbed91b5
KF		 5433 int count;
5434
d343c3ef 5435 ENTER_with_name("call_filter_sub");
55b5114f 5436 SAVE_DEFSV;
bbed91b5
KF		 5437 SAVETMPS;
5438 EXTEND(SP, 2);
5439
414bf5ae 5440 DEFSV_set(upstream);
bbed91b5 5441 PUSHMARK(SP);
6e449a3a 5442 mPUSHi(0);
bbed91b5
KF		 5443 if (filter_state) {
5444 PUSHs(filter_state);
5445 }
5446 PUTBACK;
d60d2019 5447 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
bbed91b5
KF		 5448 SPAGAIN;
5449
5450 if (count > 0) {
5451 SV *out = POPs;
5452 if (SvOK(out)) {
941a98a0 5453 status = SvIV(out);
bbed91b5 5454 }
eed484f9
DD		 5455 else {
5456 SV * const errsv = ERRSV;
5457 if (SvTRUE_NN(errsv))
5458 err = newSVsv(errsv);
d60d2019 5459 }
bbed91b5
KF		 5460 }
5461
5462 PUTBACK;
5463 FREETMPS;
d343c3ef 5464 LEAVE_with_name("call_filter_sub");
bbed91b5
KF		 5465 }
5466
b68108d9 5467 if (SvIsCOW(upstream)) sv_force_normal(upstream);
d60d2019 5468 if(!err && SvOK(upstream)) {
941a98a0 5469 got_p = SvPV(upstream, got_len);
bb7a0f54
MHM		 5470 if (umaxlen) {
5471 if (got_len > umaxlen) {
5472 prune_from = got_p + umaxlen;
937b367d 5473 }
941a98a0 5474 } else {
162177c1 5475 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
941a98a0
NC		 5476 if (first_nl && first_nl + 1 < got_p + got_len) {
5477 /* There's a second line here... */
5478 prune_from = first_nl + 1;
937b367d 5479 }
937b367d
NC		 5480 }
5481 }
d60d2019 5482 if (!err && prune_from) {
941a98a0
NC		 5483 /* Oh. Too long. Stuff some in our cache. */
5484 STRLEN cached_len = got_p + got_len - prune_from;
4464f08e 5485 SV *const cache = datasv;
941a98a0 5486
4464f08e 5487 if (SvOK(cache)) {
941a98a0
NC		 5488 /* Cache should be empty. */
5489 assert(!SvCUR(cache));
5490 }
5491
5492 sv_setpvn(cache, prune_from, cached_len);
5493 /* If you ask for block mode, you may well split UTF-8 characters.
5494 "If it breaks, you get to keep both parts"
5495 (Your code is broken if you don't put them back together again
5496 before something notices.) */
5497 if (SvUTF8(upstream)) {
5498 SvUTF8_on(cache);
5499 }
5500 SvCUR_set(upstream, got_len - cached_len);
162177c1 5501 *prune_from = 0;
941a98a0
NC		 5502 /* Can't yet be EOF */
5503 if (status == 0)
5504 status = 1;
5505 }
937b367d 5506
34113e50
NC		 5507 /* If they are at EOF but buf_sv has something in it, then they may never
5508 have touched the SV upstream, so it may be undefined. If we naively
5509 concatenate it then we get a warning about use of uninitialised value.
5510 */
d60d2019
JL		 5511 if (!err && upstream != buf_sv &&
5512 (SvOK(upstream) || SvGMAGICAL(upstream))) {
937b367d
NC		 5513 sv_catsv(buf_sv, upstream);
5514 }
5515
941a98a0 5516 if (status <= 0) {
bbed91b5 5517 IoLINES(datasv) = 0;
bbed91b5
KF		 5518 if (filter_state) {
5519 SvREFCNT_dec(filter_state);
a0714e2c 5520 IoTOP_GV(datasv) = NULL;
bbed91b5
KF		 5521 }
5522 if (filter_sub) {
5523 SvREFCNT_dec(filter_sub);
a0714e2c 5524 IoBOTTOM_GV(datasv) = NULL;
bbed91b5 5525 }
0bd48802 5526 filter_del(S_run_user_filter);
bbed91b5 5527 }
d60d2019
JL		 5528
5529 if (err)
5530 croak_sv(err);
5531
34113e50
NC		 5532 if (status == 0 && read_from_cache) {
5533 /* If we read some data from the cache (and by getting here it implies
5534 that we emptied the cache) then we aren't yet at EOF, and mustn't
5535 report that to our caller. */
5536 return 1;
5537 }
941a98a0 5538 return status;
bbed91b5 5539}
84d4ea48 5540
241d1a3b
NC		 5541/*
5542 * Local variables:
5543 * c-indentation-style: bsd
5544 * c-basic-offset: 4
14d04a33 5545 * indent-tabs-mode: nil
241d1a3b
NC		 5546 * End:
5547 *
14d04a33 5548 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5549 */
Unnamed repository; edit this file 'description' to name the repository.