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