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