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