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