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