This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bring the joy of strict to the rest of write.t
[perl5.git] / pp_ctl.c
CommitLineData
a0d0e21e
LW
1/* pp_ctl.c
2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
fdf8c088 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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/*
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
166f8a29
DM
20/* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
25 *
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
28 */
29
30
a0d0e21e 31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_PP_CTL_C
a0d0e21e
LW
33#include "perl.h"
34
35#ifndef WORD_ALIGN
dea28490 36#define WORD_ALIGN sizeof(U32)
a0d0e21e
LW
37#endif
38
54310121 39#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 40
94fcd414
NC
41#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
42
a0d0e21e
LW
43PP(pp_wantarray)
44{
97aff369 45 dVAR;
39644a26 46 dSP;
a0d0e21e
LW
47 I32 cxix;
48 EXTEND(SP, 1);
49
50 cxix = dopoptosub(cxstack_ix);
51 if (cxix < 0)
52 RETPUSHUNDEF;
53
54310121
PP
54 switch (cxstack[cxix].blk_gimme) {
55 case G_ARRAY:
a0d0e21e 56 RETPUSHYES;
54310121 57 case G_SCALAR:
a0d0e21e 58 RETPUSHNO;
54310121
PP
59 default:
60 RETPUSHUNDEF;
61 }
a0d0e21e
LW
62}
63
2cd61cdb
IZ
64PP(pp_regcreset)
65{
97aff369 66 dVAR;
2cd61cdb
IZ
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
3280af22 69 PL_reginterp_cnt = 0;
0b4182de 70 TAINT_NOT;
2cd61cdb
IZ
71 return NORMAL;
72}
73
b3eb6a9b
GS
74PP(pp_regcomp)
75{
97aff369 76 dVAR;
39644a26 77 dSP;
a0d0e21e 78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
a0d0e21e 79 SV *tmpstr;
84679df5 80 REGEXP *re = NULL;
bfed75c6 81
4b5a0d1c 82 /* prevent recompiling under /o and ithreads. */
3db8f154 83#if defined(USE_ITHREADS)
131b3ad0
DM
84 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
85 if (PL_op->op_flags & OPf_STACKED) {
86 dMARK;
87 SP = MARK;
88 }
89 else
90 (void)POPs;
91 RETURN;
92 }
513629ba 93#endif
131b3ad0
DM
94 if (PL_op->op_flags & OPf_STACKED) {
95 /* multiple args; concatentate them */
96 dMARK; dORIGMARK;
97 tmpstr = PAD_SV(ARGTARG);
98 sv_setpvn(tmpstr, "", 0);
99 while (++MARK <= SP) {
100 if (PL_amagic_generation) {
101 SV *sv;
102 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
103 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
104 {
105 sv_setsv(tmpstr, sv);
106 continue;
107 }
108 }
109 sv_catsv(tmpstr, *MARK);
110 }
111 SvSETMAGIC(tmpstr);
112 SP = ORIGMARK;
113 }
114 else
115 tmpstr = POPs;
513629ba 116
b3eb6a9b 117 if (SvROK(tmpstr)) {
d8f6592e 118 SV * const sv = SvRV(tmpstr);
5c35adbb 119 if (SvTYPE(sv) == SVt_REGEXP)
d2f13c59 120 re = (REGEXP*) sv;
c277df42 121 }
5c35adbb
NC
122 if (re) {
123 re = reg_temp_copy(re);
aaa362c4 124 ReREFCNT_dec(PM_GETRE(pm));
28d8d7f4 125 PM_SETRE(pm, re);
c277df42
IZ
126 }
127 else {
e62f0680 128 STRLEN len;
3ab4a224 129 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
c737faaf 130 re = PM_GETRE(pm);
14a49a24 131 assert (re != (REGEXP*) &PL_sv_undef);
c277df42 132
20408e3c 133 /* Check against the last compiled regexp. */
a11c8683 134 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
220fc49f 135 memNE(RX_PRECOMP(re), t, len))
85aff577 136 {
07bc277f 137 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
c737faaf 138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
d8f6592e
AL
139 if (re) {
140 ReREFCNT_dec(re);
14a49a24
NC
141#ifdef USE_ITHREADS
142 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
143#else
4608196e 144 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
14a49a24 145#endif
1e2e3d02
YO
146 } else if (PL_curcop->cop_hints_hash) {
147 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
148 "regcomp", 7, 0, 0);
149 if (ptr && SvIOK(ptr) && SvIV(ptr))
150 eng = INT2PTR(regexp_engine*,SvIV(ptr));
c277df42 151 }
664e119d 152
533c011a 153 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 154 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 155
b9ad30b4
NC
156 if (DO_UTF8(tmpstr)) {
157 assert (SvUTF8(tmpstr));
158 } else if (SvUTF8(tmpstr)) {
159 /* Not doing UTF-8, despite what the SV says. Is this only if
160 we're trapped in use 'bytes'? */
161 /* Make a copy of the octet sequence, but without the flag on,
162 as the compiler now honours the SvUTF8 flag on tmpstr. */
163 STRLEN len;
164 const char *const p = SvPV(tmpstr, len);
165 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
166 }
c737faaf 167
3ab4a224
AB
168 if (eng)
169 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
170 else
171 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
c737faaf 172
f86aaa29 173 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 174 inside tie/overload accessors. */
c277df42 175 }
4633a7c4 176 }
c737faaf
YO
177
178 re = PM_GETRE(pm);
a0d0e21e 179
72311751 180#ifndef INCOMPLETE_TAINTS
3280af22
NIS
181 if (PL_tainting) {
182 if (PL_tainted)
07bc277f 183 RX_EXTFLAGS(re) |= RXf_TAINTED;
72311751 184 else
07bc277f 185 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
72311751
GS
186 }
187#endif
188
220fc49f 189 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
3280af22 190 pm = PL_curpm;
a0d0e21e 191
c737faaf
YO
192
193#if !defined(USE_ITHREADS)
194 /* can't change the optree at runtime either */
195 /* PMf_KEEP is handled differently under threads to avoid these problems */
a0d0e21e 196 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 197 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
533c011a 198 cLOGOP->op_first->op_next = PL_op->op_next;
a0d0e21e 199 }
c737faaf 200#endif
a0d0e21e
LW
201 RETURN;
202}
203
204PP(pp_substcont)
205{
97aff369 206 dVAR;
39644a26 207 dSP;
c09156bb 208 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
901017d6
AL
209 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
210 register SV * const dstr = cx->sb_dstr;
a0d0e21e
LW
211 register char *s = cx->sb_s;
212 register char *m = cx->sb_m;
213 char *orig = cx->sb_orig;
901017d6 214 register REGEXP * const rx = cx->sb_rx;
c445ea15 215 SV *nsv = NULL;
988e6e7e
AE
216 REGEXP *old = PM_GETRE(pm);
217 if(old != rx) {
bfed75c6 218 if(old)
988e6e7e 219 ReREFCNT_dec(old);
d6106309 220 PM_SETRE(pm,ReREFCNT_inc(rx));
d8f2cf8a
AB
221 }
222
d9f97599 223 rxres_restore(&cx->sb_rxres, rx);
01b35787 224 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
c90c0ff4 225
a0d0e21e 226 if (cx->sb_iters++) {
a3b680e6 227 const I32 saviters = cx->sb_iters;
a0d0e21e 228 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 229 DIE(aTHX_ "Substitution loop");
a0d0e21e 230
48c036b1
GS
231 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
232 cx->sb_rxtainted |= 2;
a0d0e21e 233 sv_catsv(dstr, POPs);
a0d0e21e
LW
234
235 /* Are we done */
c5bed6a7 236 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
9661b544 237 s == m, cx->sb_targ, NULL,
22e551b9 238 ((cx->sb_rflags & REXEC_COPY_STR)
cf93c79d
IZ
239 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
240 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e 241 {
823a54a3 242 SV * const targ = cx->sb_targ;
748a9306 243
078c425b
JH
244 assert(cx->sb_strend >= s);
245 if(cx->sb_strend > s) {
246 if (DO_UTF8(dstr) && !SvUTF8(targ))
247 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
248 else
249 sv_catpvn(dstr, s, cx->sb_strend - s);
250 }
48c036b1 251 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 252
f8c7b90f 253#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
254 if (SvIsCOW(targ)) {
255 sv_force_normal_flags(targ, SV_COW_DROP_PV);
256 } else
257#endif
258 {
8bd4d4c5 259 SvPV_free(targ);
ed252734 260 }
f880fe2f 261 SvPV_set(targ, SvPVX(dstr));
748a9306
LW
262 SvCUR_set(targ, SvCUR(dstr));
263 SvLEN_set(targ, SvLEN(dstr));
1aa99e6b
IH
264 if (DO_UTF8(dstr))
265 SvUTF8_on(targ);
6136c704 266 SvPV_set(dstr, NULL);
48c036b1
GS
267
268 TAINT_IF(cx->sb_rxtainted & 1);
6e449a3a 269 mPUSHi(saviters - 1);
48c036b1 270
ffc61ed2 271 (void)SvPOK_only_UTF8(targ);
48c036b1 272 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 273 SvSETMAGIC(targ);
9212bbba 274 SvTAINT(targ);
5cd24f17 275
4633a7c4 276 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW
277 POPSUBST(cx);
278 RETURNOP(pm->op_next);
279 }
8e5e9ebe 280 cx->sb_iters = saviters;
a0d0e21e 281 }
07bc277f 282 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
a0d0e21e
LW
283 m = s;
284 s = orig;
07bc277f 285 cx->sb_orig = orig = RX_SUBBEG(rx);
a0d0e21e
LW
286 s = orig + (m - s);
287 cx->sb_strend = s + (cx->sb_strend - m);
288 }
07bc277f 289 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
db79b45b 290 if (m > s) {
bfed75c6 291 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
db79b45b
JH
292 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
293 else
294 sv_catpvn(dstr, s, m-s);
295 }
07bc277f 296 cx->sb_s = RX_OFFS(rx)[0].end + orig;
084916e3 297 { /* Update the pos() information. */
44f8325f 298 SV * const sv = cx->sb_targ;
084916e3 299 MAGIC *mg;
7a7f3e45 300 SvUPGRADE(sv, SVt_PVMG);
14befaf4 301 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
d83f0a82 302#ifdef PERL_OLD_COPY_ON_WRITE
51a9ea20 303 if (SvIsCOW(sv))
d83f0a82
NC
304 sv_force_normal_flags(sv, 0);
305#endif
306 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
307 NULL, 0);
084916e3 308 }
ce474962 309 mg->mg_len = m - orig;
084916e3 310 }
988e6e7e 311 if (old != rx)
d6106309 312 (void)ReREFCNT_inc(rx);
d9f97599
GS
313 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
314 rxres_save(&cx->sb_rxres, rx);
29f2e912 315 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
a0d0e21e
LW
316}
317
c90c0ff4 318void
864dbfa3 319Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP
320{
321 UV *p = (UV*)*rsp;
322 U32 i;
7918f24d
NC
323
324 PERL_ARGS_ASSERT_RXRES_SAVE;
96a5add6 325 PERL_UNUSED_CONTEXT;
c90c0ff4 326
07bc277f 327 if (!p || p[1] < RX_NPARENS(rx)) {
f8c7b90f 328#ifdef PERL_OLD_COPY_ON_WRITE
07bc277f 329 i = 7 + RX_NPARENS(rx) * 2;
ed252734 330#else
07bc277f 331 i = 6 + RX_NPARENS(rx) * 2;
ed252734 332#endif
c90c0ff4 333 if (!p)
a02a5408 334 Newx(p, i, UV);
c90c0ff4
PP
335 else
336 Renew(p, i, UV);
337 *rsp = (void*)p;
338 }
339
07bc277f 340 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
cf93c79d 341 RX_MATCH_COPIED_off(rx);
c90c0ff4 342
f8c7b90f 343#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1
NC
344 *p++ = PTR2UV(RX_SAVED_COPY(rx));
345 RX_SAVED_COPY(rx) = NULL;
ed252734
NC
346#endif
347
07bc277f 348 *p++ = RX_NPARENS(rx);
c90c0ff4 349
07bc277f
NC
350 *p++ = PTR2UV(RX_SUBBEG(rx));
351 *p++ = (UV)RX_SUBLEN(rx);
352 for (i = 0; i <= RX_NPARENS(rx); ++i) {
353 *p++ = (UV)RX_OFFS(rx)[i].start;
354 *p++ = (UV)RX_OFFS(rx)[i].end;
c90c0ff4
PP
355 }
356}
357
358void
864dbfa3 359Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP
360{
361 UV *p = (UV*)*rsp;
362 U32 i;
7918f24d
NC
363
364 PERL_ARGS_ASSERT_RXRES_RESTORE;
96a5add6 365 PERL_UNUSED_CONTEXT;
c90c0ff4 366
ed252734 367 RX_MATCH_COPY_FREE(rx);
cf93c79d 368 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4
PP
369 *p++ = 0;
370
f8c7b90f 371#ifdef PERL_OLD_COPY_ON_WRITE
bdd9a1b1
NC
372 if (RX_SAVED_COPY(rx))
373 SvREFCNT_dec (RX_SAVED_COPY(rx));
374 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
ed252734
NC
375 *p++ = 0;
376#endif
377
07bc277f 378 RX_NPARENS(rx) = *p++;
c90c0ff4 379
07bc277f
NC
380 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
381 RX_SUBLEN(rx) = (I32)(*p++);
382 for (i = 0; i <= RX_NPARENS(rx); ++i) {
383 RX_OFFS(rx)[i].start = (I32)(*p++);
384 RX_OFFS(rx)[i].end = (I32)(*p++);
c90c0ff4
PP
385 }
386}
387
388void
864dbfa3 389Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 390{
44f8325f 391 UV * const p = (UV*)*rsp;
7918f24d
NC
392
393 PERL_ARGS_ASSERT_RXRES_FREE;
96a5add6 394 PERL_UNUSED_CONTEXT;
c90c0ff4
PP
395
396 if (p) {
94010e71
NC
397#ifdef PERL_POISON
398 void *tmp = INT2PTR(char*,*p);
399 Safefree(tmp);
400 if (*p)
7e337ee0 401 PoisonFree(*p, 1, sizeof(*p));
94010e71 402#else
56431972 403 Safefree(INT2PTR(char*,*p));
94010e71 404#endif
f8c7b90f 405#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
406 if (p[1]) {
407 SvREFCNT_dec (INT2PTR(SV*,p[1]));
408 }
409#endif
c90c0ff4 410 Safefree(p);
4608196e 411 *rsp = NULL;
c90c0ff4
PP
412 }
413}
414
a0d0e21e
LW
415PP(pp_formline)
416{
97aff369 417 dVAR; dSP; dMARK; dORIGMARK;
823a54a3 418 register SV * const tmpForm = *++MARK;
dea28490 419 register U32 *fpc;
a0d0e21e 420 register char *t;
245d4a47 421 const char *f;
a0d0e21e 422 register I32 arg;
c445ea15
AL
423 register SV *sv = NULL;
424 const char *item = NULL;
9c5ffd7c
JH
425 I32 itemsize = 0;
426 I32 fieldsize = 0;
a0d0e21e 427 I32 lines = 0;
c445ea15
AL
428 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
429 const char *chophere = NULL;
430 char *linemark = NULL;
65202027 431 NV value;
9c5ffd7c 432 bool gotsome = FALSE;
a0d0e21e 433 STRLEN len;
823a54a3 434 const STRLEN fudge = SvPOK(tmpForm)
24c89738 435 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
1bd51a4c
IH
436 bool item_is_utf8 = FALSE;
437 bool targ_is_utf8 = FALSE;
c445ea15 438 SV * nsv = NULL;
cbbf8932 439 OP * parseres = NULL;
bfed75c6 440 const char *fmt;
a1b95068 441 bool oneline;
a0d0e21e 442
76e3520e 443 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445b3f51
GS
444 if (SvREADONLY(tmpForm)) {
445 SvREADONLY_off(tmpForm);
a1b95068 446 parseres = doparseform(tmpForm);
445b3f51
GS
447 SvREADONLY_on(tmpForm);
448 }
449 else
a1b95068
LW
450 parseres = doparseform(tmpForm);
451 if (parseres)
452 return parseres;
a0d0e21e 453 }
3280af22 454 SvPV_force(PL_formtarget, len);
1bd51a4c
IH
455 if (DO_UTF8(PL_formtarget))
456 targ_is_utf8 = TRUE;
a0ed51b3 457 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 458 t += len;
245d4a47 459 f = SvPV_const(tmpForm, len);
a0d0e21e 460 /* need to jump to the next word */
245d4a47 461 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
a0d0e21e
LW
462
463 for (;;) {
464 DEBUG_f( {
bfed75c6 465 const char *name = "???";
a0d0e21e
LW
466 arg = -1;
467 switch (*fpc) {
468 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
469 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
470 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
471 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
472 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
473
474 case FF_CHECKNL: name = "CHECKNL"; break;
475 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
476 case FF_SPACE: name = "SPACE"; break;
477 case FF_HALFSPACE: name = "HALFSPACE"; break;
478 case FF_ITEM: name = "ITEM"; break;
479 case FF_CHOP: name = "CHOP"; break;
480 case FF_LINEGLOB: name = "LINEGLOB"; break;
481 case FF_NEWLINE: name = "NEWLINE"; break;
482 case FF_MORE: name = "MORE"; break;
483 case FF_LINEMARK: name = "LINEMARK"; break;
484 case FF_END: name = "END"; break;
bfed75c6 485 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 486 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW
487 }
488 if (arg >= 0)
bf49b057 489 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 490 else
bf49b057 491 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 492 } );
a0d0e21e
LW
493 switch (*fpc++) {
494 case FF_LINEMARK:
495 linemark = t;
a0d0e21e
LW
496 lines++;
497 gotsome = FALSE;
498 break;
499
500 case FF_LITERAL:
501 arg = *fpc++;
1bd51a4c 502 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
b15aece3 503 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
78da4d13
JH
504 *t = '\0';
505 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
506 t = SvEND(PL_formtarget);
1bd51a4c
IH
507 break;
508 }
509 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
b15aece3 510 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH
511 *t = '\0';
512 sv_utf8_upgrade(PL_formtarget);
513 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
514 t = SvEND(PL_formtarget);
515 targ_is_utf8 = TRUE;
516 }
a0d0e21e
LW
517 while (arg--)
518 *t++ = *f++;
519 break;
520
521 case FF_SKIP:
522 f += *fpc++;
523 break;
524
525 case FF_FETCH:
526 arg = *fpc++;
527 f += arg;
528 fieldsize = arg;
529
530 if (MARK < SP)
531 sv = *++MARK;
532 else {
3280af22 533 sv = &PL_sv_no;
599cee73 534 if (ckWARN(WARN_SYNTAX))
9014280d 535 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e
LW
536 }
537 break;
538
539 case FF_CHECKNL:
5a34cab7
NC
540 {
541 const char *send;
542 const char *s = item = SvPV_const(sv, len);
543 itemsize = len;
544 if (DO_UTF8(sv)) {
545 itemsize = sv_len_utf8(sv);
546 if (itemsize != (I32)len) {
547 I32 itembytes;
548 if (itemsize > fieldsize) {
549 itemsize = fieldsize;
550 itembytes = itemsize;
551 sv_pos_u2b(sv, &itembytes, 0);
552 }
553 else
554 itembytes = len;
555 send = chophere = s + itembytes;
556 while (s < send) {
557 if (*s & ~31)
558 gotsome = TRUE;
559 else if (*s == '\n')
560 break;
561 s++;
562 }
563 item_is_utf8 = TRUE;
564 itemsize = s - item;
565 sv_pos_b2u(sv, &itemsize);
566 break;
a0ed51b3 567 }
a0ed51b3 568 }
5a34cab7
NC
569 item_is_utf8 = FALSE;
570 if (itemsize > fieldsize)
571 itemsize = fieldsize;
572 send = chophere = s + itemsize;
573 while (s < send) {
574 if (*s & ~31)
575 gotsome = TRUE;
576 else if (*s == '\n')
577 break;
578 s++;
579 }
580 itemsize = s - item;
581 break;
a0ed51b3 582 }
a0d0e21e
LW
583
584 case FF_CHECKCHOP:
5a34cab7
NC
585 {
586 const char *s = item = SvPV_const(sv, len);
587 itemsize = len;
588 if (DO_UTF8(sv)) {
589 itemsize = sv_len_utf8(sv);
590 if (itemsize != (I32)len) {
591 I32 itembytes;
592 if (itemsize <= fieldsize) {
593 const char *send = chophere = s + itemsize;
594 while (s < send) {
595 if (*s == '\r') {
596 itemsize = s - item;
a0ed51b3 597 chophere = s;
a0ed51b3 598 break;
5a34cab7
NC
599 }
600 if (*s++ & ~31)
a0ed51b3 601 gotsome = TRUE;
a0ed51b3 602 }
a0ed51b3 603 }
5a34cab7
NC
604 else {
605 const char *send;
606 itemsize = fieldsize;
607 itembytes = itemsize;
608 sv_pos_u2b(sv, &itembytes, 0);
609 send = chophere = s + itembytes;
610 while (s < send || (s == send && isSPACE(*s))) {
611 if (isSPACE(*s)) {
612 if (chopspace)
613 chophere = s;
614 if (*s == '\r')
615 break;
616 }
617 else {
618 if (*s & ~31)
619 gotsome = TRUE;
620 if (strchr(PL_chopset, *s))
621 chophere = s + 1;
622 }
623 s++;
624 }
625 itemsize = chophere - item;
626 sv_pos_b2u(sv, &itemsize);
627 }
628 item_is_utf8 = TRUE;
a0d0e21e
LW
629 break;
630 }
a0d0e21e 631 }
5a34cab7
NC
632 item_is_utf8 = FALSE;
633 if (itemsize <= fieldsize) {
634 const char *const send = chophere = s + itemsize;
635 while (s < send) {
636 if (*s == '\r') {
637 itemsize = s - item;
a0d0e21e 638 chophere = s;
a0d0e21e 639 break;
5a34cab7
NC
640 }
641 if (*s++ & ~31)
a0d0e21e 642 gotsome = TRUE;
a0d0e21e 643 }
a0d0e21e 644 }
5a34cab7
NC
645 else {
646 const char *send;
647 itemsize = fieldsize;
648 send = chophere = s + itemsize;
649 while (s < send || (s == send && isSPACE(*s))) {
650 if (isSPACE(*s)) {
651 if (chopspace)
652 chophere = s;
653 if (*s == '\r')
654 break;
655 }
656 else {
657 if (*s & ~31)
658 gotsome = TRUE;
659 if (strchr(PL_chopset, *s))
660 chophere = s + 1;
661 }
662 s++;
663 }
664 itemsize = chophere - item;
665 }
666 break;
a0d0e21e 667 }
a0d0e21e
LW
668
669 case FF_SPACE:
670 arg = fieldsize - itemsize;
671 if (arg) {
672 fieldsize -= arg;
673 while (arg-- > 0)
674 *t++ = ' ';
675 }
676 break;
677
678 case FF_HALFSPACE:
679 arg = fieldsize - itemsize;
680 if (arg) {
681 arg /= 2;
682 fieldsize -= arg;
683 while (arg-- > 0)
684 *t++ = ' ';
685 }
686 break;
687
688 case FF_ITEM:
5a34cab7
NC
689 {
690 const char *s = item;
691 arg = itemsize;
692 if (item_is_utf8) {
693 if (!targ_is_utf8) {
694 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
695 *t = '\0';
696 sv_utf8_upgrade(PL_formtarget);
697 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
698 t = SvEND(PL_formtarget);
699 targ_is_utf8 = TRUE;
a0ed51b3 700 }
5a34cab7
NC
701 while (arg--) {
702 if (UTF8_IS_CONTINUED(*s)) {
703 STRLEN skip = UTF8SKIP(s);
704 switch (skip) {
705 default:
706 Move(s,t,skip,char);
707 s += skip;
708 t += skip;
709 break;
710 case 7: *t++ = *s++;
711 case 6: *t++ = *s++;
712 case 5: *t++ = *s++;
713 case 4: *t++ = *s++;
714 case 3: *t++ = *s++;
715 case 2: *t++ = *s++;
716 case 1: *t++ = *s++;
717 }
718 }
719 else {
720 if ( !((*t++ = *s++) & ~31) )
721 t[-1] = ' ';
722 }
a0ed51b3 723 }
5a34cab7 724 break;
a0ed51b3 725 }
5a34cab7
NC
726 if (targ_is_utf8 && !item_is_utf8) {
727 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
728 *t = '\0';
729 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
730 for (; t < SvEND(PL_formtarget); t++) {
78da4d13 731#ifdef EBCDIC
901017d6 732 const int ch = *t;
5a34cab7 733 if (iscntrl(ch))
78da4d13 734#else
5a34cab7 735 if (!(*t & ~31))
78da4d13 736#endif
5a34cab7
NC
737 *t = ' ';
738 }
739 break;
78da4d13 740 }
5a34cab7 741 while (arg--) {
9d116dd7 742#ifdef EBCDIC
901017d6 743 const int ch = *t++ = *s++;
5a34cab7 744 if (iscntrl(ch))
a0d0e21e 745#else
5a34cab7 746 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 747#endif
5a34cab7
NC
748 t[-1] = ' ';
749 }
750 break;
a0d0e21e 751 }
a0d0e21e
LW
752
753 case FF_CHOP:
5a34cab7
NC
754 {
755 const char *s = chophere;
756 if (chopspace) {
af68e756 757 while (isSPACE(*s))
5a34cab7
NC
758 s++;
759 }
760 sv_chop(sv,s);
761 SvSETMAGIC(sv);
762 break;
a0d0e21e 763 }
a0d0e21e 764
a1b95068
LW
765 case FF_LINESNGL:
766 chopspace = 0;
767 oneline = TRUE;
768 goto ff_line;
a0d0e21e 769 case FF_LINEGLOB:
a1b95068
LW
770 oneline = FALSE;
771 ff_line:
5a34cab7
NC
772 {
773 const char *s = item = SvPV_const(sv, len);
774 itemsize = len;
775 if ((item_is_utf8 = DO_UTF8(sv)))
776 itemsize = sv_len_utf8(sv);
777 if (itemsize) {
778 bool chopped = FALSE;
779 const char *const send = s + len;
780 gotsome = TRUE;
781 chophere = s + itemsize;
782 while (s < send) {
783 if (*s++ == '\n') {
784 if (oneline) {
785 chopped = TRUE;
786 chophere = s;
787 break;
788 } else {
789 if (s == send) {
790 itemsize--;
791 chopped = TRUE;
792 } else
793 lines++;
794 }
1bd51a4c 795 }
a0d0e21e 796 }
5a34cab7
NC
797 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
798 if (targ_is_utf8)
799 SvUTF8_on(PL_formtarget);
800 if (oneline) {
801 SvCUR_set(sv, chophere - item);
802 sv_catsv(PL_formtarget, sv);
803 SvCUR_set(sv, itemsize);
804 } else
805 sv_catsv(PL_formtarget, sv);
806 if (chopped)
807 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
808 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
809 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
810 if (item_is_utf8)
811 targ_is_utf8 = TRUE;
a0d0e21e 812 }
5a34cab7 813 break;
a0d0e21e 814 }
a0d0e21e 815
a1b95068
LW
816 case FF_0DECIMAL:
817 arg = *fpc++;
818#if defined(USE_LONG_DOUBLE)
10edeb5d
JH
819 fmt = (const char *)
820 ((arg & 256) ?
821 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
a1b95068 822#else
10edeb5d
JH
823 fmt = (const char *)
824 ((arg & 256) ?
825 "%#0*.*f" : "%0*.*f");
a1b95068
LW
826#endif
827 goto ff_dec;
a0d0e21e 828 case FF_DECIMAL:
a0d0e21e 829 arg = *fpc++;
65202027 830#if defined(USE_LONG_DOUBLE)
10edeb5d
JH
831 fmt = (const char *)
832 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
65202027 833#else
10edeb5d
JH
834 fmt = (const char *)
835 ((arg & 256) ? "%#*.*f" : "%*.*f");
65202027 836#endif
a1b95068 837 ff_dec:
784707d5
JP
838 /* If the field is marked with ^ and the value is undefined,
839 blank it out. */
784707d5
JP
840 if ((arg & 512) && !SvOK(sv)) {
841 arg = fieldsize;
842 while (arg--)
843 *t++ = ' ';
844 break;
845 }
846 gotsome = TRUE;
847 value = SvNV(sv);
a1b95068 848 /* overflow evidence */
bfed75c6 849 if (num_overflow(value, fieldsize, arg)) {
a1b95068
LW
850 arg = fieldsize;
851 while (arg--)
852 *t++ = '#';
853 break;
854 }
784707d5
JP
855 /* Formats aren't yet marked for locales, so assume "yes". */
856 {
857 STORE_NUMERIC_STANDARD_SET_LOCAL();
d9fad198 858 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
784707d5
JP
859 RESTORE_NUMERIC_STANDARD();
860 }
861 t += fieldsize;
862 break;
a1b95068 863
a0d0e21e
LW
864 case FF_NEWLINE:
865 f++;
866 while (t-- > linemark && *t == ' ') ;
867 t++;
868 *t++ = '\n';
869 break;
870
871 case FF_BLANK:
872 arg = *fpc++;
873 if (gotsome) {
874 if (arg) { /* repeat until fields exhausted? */
875 *t = '\0';
b15aece3 876 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
3280af22 877 lines += FmLINES(PL_formtarget);
a0d0e21e
LW
878 if (lines == 200) {
879 arg = t - linemark;
880 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 881 DIE(aTHX_ "Runaway format");
a0d0e21e 882 }
1bd51a4c
IH
883 if (targ_is_utf8)
884 SvUTF8_on(PL_formtarget);
3280af22 885 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW
886 SP = ORIGMARK;
887 RETURNOP(cLISTOP->op_first);
888 }
889 }
890 else {
891 t = linemark;
892 lines--;
893 }
894 break;
895
896 case FF_MORE:
5a34cab7
NC
897 {
898 const char *s = chophere;
899 const char *send = item + len;
900 if (chopspace) {
af68e756 901 while (isSPACE(*s) && (s < send))
5a34cab7 902 s++;
a0d0e21e 903 }
5a34cab7
NC
904 if (s < send) {
905 char *s1;
906 arg = fieldsize - itemsize;
907 if (arg) {
908 fieldsize -= arg;
909 while (arg-- > 0)
910 *t++ = ' ';
911 }
912 s1 = t - 3;
913 if (strnEQ(s1," ",3)) {
914 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
915 s1--;
916 }
917 *s1++ = '.';
918 *s1++ = '.';
919 *s1++ = '.';
a0d0e21e 920 }
5a34cab7 921 break;
a0d0e21e 922 }
a0d0e21e
LW
923 case FF_END:
924 *t = '\0';
b15aece3 925 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH
926 if (targ_is_utf8)
927 SvUTF8_on(PL_formtarget);
3280af22 928 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW
929 SP = ORIGMARK;
930 RETPUSHYES;
931 }
932 }
933}
934
935PP(pp_grepstart)
936{
27da23d5 937 dVAR; dSP;
a0d0e21e
LW
938 SV *src;
939
3280af22 940 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 941 (void)POPMARK;
54310121 942 if (GIMME_V == G_SCALAR)
6e449a3a 943 mXPUSHi(0);
533c011a 944 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 945 }
3280af22 946 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS
947 pp_pushmark(); /* push dst */
948 pp_pushmark(); /* push src */
a0d0e21e
LW
949 ENTER; /* enter outer scope */
950
951 SAVETMPS;
59f00321
RGS
952 if (PL_op->op_private & OPpGREP_LEX)
953 SAVESPTR(PAD_SVl(PL_op->op_targ));
954 else
955 SAVE_DEFSV;
a0d0e21e 956 ENTER; /* enter inner scope */
7766f137 957 SAVEVPTR(PL_curpm);
a0d0e21e 958
3280af22 959 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 960 SvTEMP_off(src);
59f00321
RGS
961 if (PL_op->op_private & OPpGREP_LEX)
962 PAD_SVl(PL_op->op_targ) = src;
963 else
964 DEFSV = src;
a0d0e21e
LW
965
966 PUTBACK;
533c011a 967 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 968 pp_pushmark(); /* push top */
533c011a 969 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW
970}
971
a0d0e21e
LW
972PP(pp_mapwhile)
973{
27da23d5 974 dVAR; dSP;
f54cb97a 975 const I32 gimme = GIMME_V;
544f3153 976 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW
977 I32 count;
978 I32 shift;
979 SV** src;
ac27b0f5 980 SV** dst;
a0d0e21e 981
544f3153 982 /* first, move source pointer to the next item in the source list */
3280af22 983 ++PL_markstack_ptr[-1];
544f3153
GS
984
985 /* if there are new items, push them into the destination list */
4c90a460 986 if (items && gimme != G_VOID) {
544f3153
GS
987 /* might need to make room back there first */
988 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
989 /* XXX this implementation is very pessimal because the stack
990 * is repeatedly extended for every set of items. Is possible
991 * to do this without any stack extension or copying at all
992 * by maintaining a separate list over which the map iterates
18ef8bea 993 * (like foreach does). --gsar */
544f3153
GS
994
995 /* everything in the stack after the destination list moves
996 * towards the end the stack by the amount of room needed */
997 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
998
999 /* items to shift up (accounting for the moved source pointer) */
1000 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT
1001
1002 /* This optimization is by Ben Tilly and it does
1003 * things differently from what Sarathy (gsar)
1004 * is describing. The downside of this optimization is
1005 * that leaves "holes" (uninitialized and hopefully unused areas)
1006 * to the Perl stack, but on the other hand this
1007 * shouldn't be a problem. If Sarathy's idea gets
1008 * implemented, this optimization should become
1009 * irrelevant. --jhi */
1010 if (shift < count)
1011 shift = count; /* Avoid shifting too often --Ben Tilly */
bfed75c6 1012
924508f0
GS
1013 EXTEND(SP,shift);
1014 src = SP;
1015 dst = (SP += shift);
3280af22
NIS
1016 PL_markstack_ptr[-1] += shift;
1017 *PL_markstack_ptr += shift;
544f3153 1018 while (count--)
a0d0e21e
LW
1019 *dst-- = *src--;
1020 }
544f3153 1021 /* copy the new items down to the destination list */
ac27b0f5 1022 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26
TP
1023 if (gimme == G_ARRAY) {
1024 while (items-- > 0)
1025 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1026 }
bfed75c6 1027 else {
22023b26
TP
1028 /* scalar context: we don't care about which values map returns
1029 * (we use undef here). And so we certainly don't want to do mortal
1030 * copies of meaningless values. */
1031 while (items-- > 0) {
b988aa42 1032 (void)POPs;
22023b26
TP
1033 *dst-- = &PL_sv_undef;
1034 }
1035 }
a0d0e21e
LW
1036 }
1037 LEAVE; /* exit inner scope */
1038
1039 /* All done yet? */
3280af22 1040 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW
1041
1042 (void)POPMARK; /* pop top */
1043 LEAVE; /* exit outer scope */
1044 (void)POPMARK; /* pop src */
3280af22 1045 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1046 (void)POPMARK; /* pop dst */
3280af22 1047 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1048 if (gimme == G_SCALAR) {
7cc47870
RGS
1049 if (PL_op->op_private & OPpGREP_LEX) {
1050 SV* sv = sv_newmortal();
1051 sv_setiv(sv, items);
1052 PUSHs(sv);
1053 }
1054 else {
1055 dTARGET;
1056 XPUSHi(items);
1057 }
a0d0e21e 1058 }
54310121
PP
1059 else if (gimme == G_ARRAY)
1060 SP += items;
a0d0e21e
LW
1061 RETURN;
1062 }
1063 else {
1064 SV *src;
1065
1066 ENTER; /* enter inner scope */
7766f137 1067 SAVEVPTR(PL_curpm);
a0d0e21e 1068
544f3153 1069 /* set $_ to the new source item */
3280af22 1070 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1071 SvTEMP_off(src);
59f00321
RGS
1072 if (PL_op->op_private & OPpGREP_LEX)
1073 PAD_SVl(PL_op->op_targ) = src;
1074 else
1075 DEFSV = src;
a0d0e21e
LW
1076
1077 RETURNOP(cLOGOP->op_other);
1078 }
1079}
1080
a0d0e21e
LW
1081/* Range stuff. */
1082
1083PP(pp_range)
1084{
97aff369 1085 dVAR;
a0d0e21e 1086 if (GIMME == G_ARRAY)
1a67a97c 1087 return NORMAL;
538573f7 1088 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1089 return cLOGOP->op_other;
538573f7 1090 else
1a67a97c 1091 return NORMAL;
a0d0e21e
LW
1092}
1093
1094PP(pp_flip)
1095{
97aff369 1096 dVAR;
39644a26 1097 dSP;
a0d0e21e
LW
1098
1099 if (GIMME == G_ARRAY) {
1a67a97c 1100 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW
1101 }
1102 else {
1103 dTOPss;
44f8325f 1104 SV * const targ = PAD_SV(PL_op->op_targ);
bfed75c6 1105 int flip = 0;
790090df 1106
bfed75c6 1107 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST
1108 if (GvIO(PL_last_in_gv)) {
1109 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1110 }
1111 else {
fafc274c 1112 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
44f8325f
AL
1113 if (gv && GvSV(gv))
1114 flip = SvIV(sv) == SvIV(GvSV(gv));
4e3399f9 1115 }
bfed75c6
AL
1116 } else {
1117 flip = SvTRUE(sv);
1118 }
1119 if (flip) {
a0d0e21e 1120 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1121 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1122 sv_setiv(targ, 1);
3e3baf6d 1123 SETs(targ);
a0d0e21e
LW
1124 RETURN;
1125 }
1126 else {
1127 sv_setiv(targ, 0);
924508f0 1128 SP--;
1a67a97c 1129 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW
1130 }
1131 }
c69006e4 1132 sv_setpvn(TARG, "", 0);
a0d0e21e
LW
1133 SETs(targ);
1134 RETURN;
1135 }
1136}
1137
8e9bbdb9
RGS
1138/* This code tries to decide if "$left .. $right" should use the
1139 magical string increment, or if the range is numeric (we make
1140 an exception for .."0" [#18165]). AMS 20021031. */
1141
1142#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS
1143 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1144 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e 1145 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
b15aece3 1146 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
e0ab1c0e 1147 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1148
a0d0e21e
LW
1149PP(pp_flop)
1150{
97aff369 1151 dVAR; dSP;
a0d0e21e
LW
1152
1153 if (GIMME == G_ARRAY) {
1154 dPOPPOPssrl;
86cb7173 1155
5b295bef
RD
1156 SvGETMAGIC(left);
1157 SvGETMAGIC(right);
a0d0e21e 1158
8e9bbdb9 1159 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL
1160 register IV i, j;
1161 IV max;
4fe3f0fa
MHM
1162 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1163 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1164 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW
1165 i = SvIV(left);
1166 max = SvIV(right);
bbce6d69 1167 if (max >= i) {
c1ab3db2
AK
1168 j = max - i + 1;
1169 EXTEND_MORTAL(j);
1170 EXTEND(SP, j);
bbce6d69 1171 }
c1ab3db2
AK
1172 else
1173 j = 0;
1174 while (j--) {
901017d6 1175 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW
1176 PUSHs(sv);
1177 }
1178 }
1179 else {
44f8325f 1180 SV * const final = sv_mortalcopy(right);
13c5b33c 1181 STRLEN len;
823a54a3 1182 const char * const tmps = SvPV_const(final, len);
a0d0e21e 1183
901017d6 1184 SV *sv = sv_mortalcopy(left);
13c5b33c 1185 SvPV_force_nolen(sv);
89ea2908 1186 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1187 XPUSHs(sv);
b15aece3 1188 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1189 break;
a0d0e21e
LW
1190 sv = sv_2mortal(newSVsv(sv));
1191 sv_inc(sv);
1192 }
a0d0e21e
LW
1193 }
1194 }
1195 else {
1196 dTOPss;
901017d6 1197 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1198 int flop = 0;
a0d0e21e 1199 sv_inc(targ);
4e3399f9
YST
1200
1201 if (PL_op->op_private & OPpFLIP_LINENUM) {
1202 if (GvIO(PL_last_in_gv)) {
1203 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1204 }
1205 else {
fafc274c 1206 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
4e3399f9
YST
1207 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1208 }
1209 }
1210 else {
1211 flop = SvTRUE(sv);
1212 }
1213
1214 if (flop) {
a0d0e21e 1215 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
396482e1 1216 sv_catpvs(targ, "E0");
a0d0e21e
LW
1217 }
1218 SETs(targ);
1219 }
1220
1221 RETURN;
1222}
1223
1224/* Control. */
1225
27da23d5 1226static const char * const context_name[] = {
515afda2 1227 "pseudo-block",
76753e7f
NC
1228 "when",
1229 NULL, /* CXt_BLOCK never actually needs "block" */
1230 "given",
1231 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1232 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1233 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1234 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
515afda2 1235 "subroutine",
76753e7f 1236 "format",
515afda2 1237 "eval",
515afda2 1238 "substitution",
515afda2
NC
1239};
1240
76e3520e 1241STATIC I32
06b5626a 1242S_dopoptolabel(pTHX_ const char *label)
a0d0e21e 1243{
97aff369 1244 dVAR;
a0d0e21e 1245 register I32 i;
a0d0e21e 1246
7918f24d
NC
1247 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1248
a0d0e21e 1249 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1250 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1251 switch (CxTYPE(cx)) {
a0d0e21e 1252 case CXt_SUBST:
a0d0e21e 1253 case CXt_SUB:
7766f137 1254 case CXt_FORMAT:
a0d0e21e 1255 case CXt_EVAL:
0a753a76 1256 case CXt_NULL:
0d863452
RH
1257 case CXt_GIVEN:
1258 case CXt_WHEN:
e476b1b5 1259 if (ckWARN(WARN_EXITING))
515afda2
NC
1260 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1261 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1262 if (CxTYPE(cx) == CXt_NULL)
1263 return -1;
1264 break;
c6fdafd0 1265 case CXt_LOOP_LAZYIV:
d01136d6 1266 case CXt_LOOP_LAZYSV:
3b719c58
NC
1267 case CXt_LOOP_FOR:
1268 case CXt_LOOP_PLAIN:
a61a7064 1269 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
cea2e8a9 1270 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
a61a7064 1271 (long)i, CxLABEL(cx)));
a0d0e21e
LW
1272 continue;
1273 }
cea2e8a9 1274 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW
1275 return i;
1276 }
1277 }
1278 return i;
1279}
1280
0d863452
RH
1281
1282
e50aee73 1283I32
864dbfa3 1284Perl_dowantarray(pTHX)
e50aee73 1285{
97aff369 1286 dVAR;
f54cb97a 1287 const I32 gimme = block_gimme();
54310121
PP
1288 return (gimme == G_VOID) ? G_SCALAR : gimme;
1289}
1290
1291I32
864dbfa3 1292Perl_block_gimme(pTHX)
54310121 1293{
97aff369 1294 dVAR;
06b5626a 1295 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1296 if (cxix < 0)
46fc3d4c 1297 return G_VOID;
e50aee73 1298
54310121 1299 switch (cxstack[cxix].blk_gimme) {
d2719217
GS
1300 case G_VOID:
1301 return G_VOID;
54310121 1302 case G_SCALAR:
e50aee73 1303 return G_SCALAR;
54310121
PP
1304 case G_ARRAY:
1305 return G_ARRAY;
1306 default:
cea2e8a9 1307 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS
1308 /* NOTREACHED */
1309 return 0;
54310121 1310 }
e50aee73
AD
1311}
1312
78f9721b
SM
1313I32
1314Perl_is_lvalue_sub(pTHX)
1315{
97aff369 1316 dVAR;
06b5626a 1317 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM
1318 assert(cxix >= 0); /* We should only be called from inside subs */
1319
bafb2adc
NC
1320 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1321 return CxLVAL(cxstack + cxix);
78f9721b
SM
1322 else
1323 return 0;
1324}
1325
76e3520e 1326STATIC I32
901017d6 1327S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1328{
97aff369 1329 dVAR;
a0d0e21e 1330 I32 i;
7918f24d
NC
1331
1332 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1333
a0d0e21e 1334 for (i = startingblock; i >= 0; i--) {
901017d6 1335 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1336 switch (CxTYPE(cx)) {
a0d0e21e
LW
1337 default:
1338 continue;
1339 case CXt_EVAL:
1340 case CXt_SUB:
7766f137 1341 case CXt_FORMAT:
cea2e8a9 1342 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW
1343 return i;
1344 }
1345 }
1346 return i;
1347}
1348
76e3520e 1349STATIC I32
cea2e8a9 1350S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1351{
97aff369 1352 dVAR;
a0d0e21e 1353 I32 i;
a0d0e21e 1354 for (i = startingblock; i >= 0; i--) {
06b5626a 1355 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1356 switch (CxTYPE(cx)) {
a0d0e21e
LW
1357 default:
1358 continue;
1359 case CXt_EVAL:
cea2e8a9 1360 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW
1361 return i;
1362 }
1363 }
1364 return i;
1365}
1366
76e3520e 1367STATIC I32
cea2e8a9 1368S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1369{
97aff369 1370 dVAR;
a0d0e21e 1371 I32 i;
a0d0e21e 1372 for (i = startingblock; i >= 0; i--) {
901017d6 1373 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1374 switch (CxTYPE(cx)) {
a0d0e21e 1375 case CXt_SUBST:
a0d0e21e 1376 case CXt_SUB:
7766f137 1377 case CXt_FORMAT:
a0d0e21e 1378 case CXt_EVAL:
0a753a76 1379 case CXt_NULL:
e476b1b5 1380 if (ckWARN(WARN_EXITING))
515afda2
NC
1381 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1382 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1383 if ((CxTYPE(cx)) == CXt_NULL)
1384 return -1;
1385 break;
c6fdafd0 1386 case CXt_LOOP_LAZYIV:
d01136d6 1387 case CXt_LOOP_LAZYSV:
3b719c58
NC
1388 case CXt_LOOP_FOR:
1389 case CXt_LOOP_PLAIN:
cea2e8a9 1390 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW
1391 return i;
1392 }
1393 }
1394 return i;
1395}
1396
0d863452
RH
1397STATIC I32
1398S_dopoptogiven(pTHX_ I32 startingblock)
1399{
97aff369 1400 dVAR;
0d863452
RH
1401 I32 i;
1402 for (i = startingblock; i >= 0; i--) {
1403 register const PERL_CONTEXT *cx = &cxstack[i];
1404 switch (CxTYPE(cx)) {
1405 default:
1406 continue;
1407 case CXt_GIVEN:
1408 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1409 return i;
3b719c58
NC
1410 case CXt_LOOP_PLAIN:
1411 assert(!CxFOREACHDEF(cx));
1412 break;
c6fdafd0 1413 case CXt_LOOP_LAZYIV:
d01136d6 1414 case CXt_LOOP_LAZYSV:
3b719c58 1415 case CXt_LOOP_FOR:
0d863452
RH
1416 if (CxFOREACHDEF(cx)) {
1417 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1418 return i;
1419 }
1420 }
1421 }
1422 return i;
1423}
1424
1425STATIC I32
1426S_dopoptowhen(pTHX_ I32 startingblock)
1427{
97aff369 1428 dVAR;
0d863452
RH
1429 I32 i;
1430 for (i = startingblock; i >= 0; i--) {
1431 register const PERL_CONTEXT *cx = &cxstack[i];
1432 switch (CxTYPE(cx)) {
1433 default:
1434 continue;
1435 case CXt_WHEN:
1436 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1437 return i;
1438 }
1439 }
1440 return i;
1441}
1442
a0d0e21e 1443void
864dbfa3 1444Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1445{
97aff369 1446 dVAR;
a0d0e21e
LW
1447 I32 optype;
1448
1449 while (cxstack_ix > cxix) {
b0d9ce38 1450 SV *sv;
06b5626a 1451 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1452 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1453 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1454 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1455 switch (CxTYPE(cx)) {
c90c0ff4
PP
1456 case CXt_SUBST:
1457 POPSUBST(cx);
1458 continue; /* not break */
a0d0e21e 1459 case CXt_SUB:
b0d9ce38
GS
1460 POPSUB(cx,sv);
1461 LEAVESUB(sv);
a0d0e21e
LW
1462 break;
1463 case CXt_EVAL:
1464 POPEVAL(cx);
1465 break;
c6fdafd0 1466 case CXt_LOOP_LAZYIV:
d01136d6 1467 case CXt_LOOP_LAZYSV:
3b719c58
NC
1468 case CXt_LOOP_FOR:
1469 case CXt_LOOP_PLAIN:
a0d0e21e
LW
1470 POPLOOP(cx);
1471 break;
0a753a76 1472 case CXt_NULL:
a0d0e21e 1473 break;
7766f137
GS
1474 case CXt_FORMAT:
1475 POPFORMAT(cx);
1476 break;
a0d0e21e 1477 }
c90c0ff4 1478 cxstack_ix--;
a0d0e21e 1479 }
1b6737cc 1480 PERL_UNUSED_VAR(optype);
a0d0e21e
LW
1481}
1482
5a844595
GS
1483void
1484Perl_qerror(pTHX_ SV *err)
1485{
97aff369 1486 dVAR;
7918f24d
NC
1487
1488 PERL_ARGS_ASSERT_QERROR;
1489
5a844595
GS
1490 if (PL_in_eval)
1491 sv_catsv(ERRSV, err);
1492 else if (PL_errors)
1493 sv_catsv(PL_errors, err);
1494 else
be2597df 1495 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
13765c85
DM
1496 if (PL_parser)
1497 ++PL_parser->error_count;
5a844595
GS
1498}
1499
a0d0e21e 1500OP *
35a4481c 1501Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1502{
27da23d5 1503 dVAR;
87582a92 1504
3280af22 1505 if (PL_in_eval) {
a0d0e21e 1506 I32 cxix;
a0d0e21e 1507 I32 gimme;
a0d0e21e 1508
4e6ea2c3 1509 if (message) {
faef0170 1510 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1511 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1512 SV * const err = ERRSV;
c445ea15 1513 const char *e = NULL;
98eae8f5 1514 if (!SvPOK(err))
c69006e4 1515 sv_setpvn(err,"",0);
98eae8f5 1516 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1517 STRLEN len;
349d4f2f 1518 e = SvPV_const(err, len);
0510663f 1519 e += len - msglen;
98eae8f5 1520 if (*e != *message || strNE(e,message))
c445ea15 1521 e = NULL;
98eae8f5
GS
1522 }
1523 if (!e) {
1524 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1525 sv_catpvn(err, prefix, sizeof(prefix)-1);
1526 sv_catpvn(err, message, msglen);
e476b1b5 1527 if (ckWARN(WARN_MISC)) {
504618e9 1528 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1529 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1530 }
4633a7c4 1531 }
4633a7c4 1532 }
1aa99e6b 1533 else {
06bf62c7 1534 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1535 }
4633a7c4 1536 }
4e6ea2c3 1537
5a844595
GS
1538 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1539 && PL_curstackinfo->si_prev)
1540 {
bac4b2ad 1541 dounwind(-1);
d3acc0f7 1542 POPSTACK;
bac4b2ad 1543 }
e336de0d 1544
a0d0e21e
LW
1545 if (cxix >= 0) {
1546 I32 optype;
35a4481c 1547 register PERL_CONTEXT *cx;
901017d6 1548 SV **newsp;
a0d0e21e
LW
1549
1550 if (cxix < cxstack_ix)
1551 dounwind(cxix);
1552
3280af22 1553 POPBLOCK(cx,PL_curpm);
6b35e009 1554 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1555 if (!message)
349d4f2f 1556 message = SvPVx_const(ERRSV, msglen);
10edeb5d 1557 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
bf49b057 1558 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW
1559 my_exit(1);
1560 }
1561 POPEVAL(cx);
1562
1563 if (gimme == G_SCALAR)
3280af22
NIS
1564 *++newsp = &PL_sv_undef;
1565 PL_stack_sp = newsp;
a0d0e21e
LW
1566
1567 LEAVE;
748a9306 1568
7fb6a879
GS
1569 /* LEAVE could clobber PL_curcop (see save_re_context())
1570 * XXX it might be better to find a way to avoid messing with
1571 * PL_curcop in save_re_context() instead, but this is a more
1572 * minimal fix --GSAR */
1573 PL_curcop = cx->blk_oldcop;
1574
7a2e2cd6 1575 if (optype == OP_REQUIRE) {
44f8325f 1576 const char* const msg = SvPVx_nolen_const(ERRSV);
901017d6 1577 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1578 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1579 &PL_sv_undef, 0);
5a844595
GS
1580 DIE(aTHX_ "%sCompilation failed in require",
1581 *msg ? msg : "Unknown error\n");
7a2e2cd6 1582 }
f39bc417
DM
1583 assert(CxTYPE(cx) == CXt_EVAL);
1584 return cx->blk_eval.retop;
a0d0e21e
LW
1585 }
1586 }
9cc2fdd3 1587 if (!message)
349d4f2f 1588 message = SvPVx_const(ERRSV, msglen);
87582a92 1589
7ff03255 1590 write_to_stderr(message, msglen);
f86702cc
PP
1591 my_failure_exit();
1592 /* NOTREACHED */
a0d0e21e
LW
1593 return 0;
1594}
1595
1596PP(pp_xor)
1597{
97aff369 1598 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW
1599 if (SvTRUE(left) != SvTRUE(right))
1600 RETSETYES;
1601 else
1602 RETSETNO;
1603}
1604
a0d0e21e
LW
1605PP(pp_caller)
1606{
97aff369 1607 dVAR;
39644a26 1608 dSP;
a0d0e21e 1609 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL
1610 register const PERL_CONTEXT *cx;
1611 register const PERL_CONTEXT *ccstack = cxstack;
1612 const PERL_SI *top_si = PL_curstackinfo;
54310121 1613 I32 gimme;
06b5626a 1614 const char *stashname;
a0d0e21e
LW
1615 I32 count = 0;
1616
1617 if (MAXARG)
1618 count = POPi;
27d41816 1619
a0d0e21e 1620 for (;;) {
2c375eb9
GS
1621 /* we may be in a higher stacklevel, so dig down deeper */
1622 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1623 top_si = top_si->si_prev;
1624 ccstack = top_si->si_cxstack;
1625 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1626 }
a0d0e21e 1627 if (cxix < 0) {
27d41816
DM
1628 if (GIMME != G_ARRAY) {
1629 EXTEND(SP, 1);
a0d0e21e 1630 RETPUSHUNDEF;
27d41816 1631 }
a0d0e21e
LW
1632 RETURN;
1633 }
f2a7f298 1634 /* caller() should not report the automatic calls to &DB::sub */
1635 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1636 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1637 count++;
1638 if (!count--)
1639 break;
2c375eb9 1640 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1641 }
2c375eb9
GS
1642
1643 cx = &ccstack[cxix];
7766f137 1644 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1645 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1646 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1647 field below is defined for any cx. */
f2a7f298 1648 /* caller() should not report the automatic calls to &DB::sub */
1649 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1650 cx = &ccstack[dbcxix];
06a5b730
PP
1651 }
1652
ed094faf 1653 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1654 if (GIMME != G_ARRAY) {
27d41816 1655 EXTEND(SP, 1);
ed094faf 1656 if (!stashname)
3280af22 1657 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1658 else {
1659 dTARGET;
ed094faf 1660 sv_setpv(TARG, stashname);
49d8d3a1
MB
1661 PUSHs(TARG);
1662 }
a0d0e21e
LW
1663 RETURN;
1664 }
a0d0e21e 1665
b3ca2e83 1666 EXTEND(SP, 11);
27d41816 1667
ed094faf 1668 if (!stashname)
3280af22 1669 PUSHs(&PL_sv_undef);
49d8d3a1 1670 else
6e449a3a
MHM
1671 mPUSHs(newSVpv(stashname, 0));
1672 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1673 mPUSHi((I32)CopLINE(cx->blk_oldcop));
a0d0e21e
LW
1674 if (!MAXARG)
1675 RETURN;
7766f137 1676 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1677 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1678 /* So is ccstack[dbcxix]. */
07b8c804 1679 if (isGV(cvgv)) {
561b68a9 1680 SV * const sv = newSV(0);
c445ea15 1681 gv_efullname3(sv, cvgv, NULL);
6e449a3a 1682 mPUSHs(sv);
bf38a478 1683 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804
RGS
1684 }
1685 else {
84bafc02 1686 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
bf38a478 1687 PUSHs(boolSV(CxHASARGS(cx)));
07b8c804 1688 }
a0d0e21e
LW
1689 }
1690 else {
84bafc02 1691 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
6e449a3a 1692 mPUSHi(0);
a0d0e21e 1693 }
54310121
PP
1694 gimme = (I32)cx->blk_gimme;
1695 if (gimme == G_VOID)
3280af22 1696 PUSHs(&PL_sv_undef);
54310121 1697 else
98625aca 1698 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
6b35e009 1699 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1700 /* eval STRING */
85a64632 1701 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
4633a7c4 1702 PUSHs(cx->blk_eval.cur_text);
3280af22 1703 PUSHs(&PL_sv_no);
0f79a09d 1704 }
811a4de9 1705 /* require */
0f79a09d 1706 else if (cx->blk_eval.old_namesv) {
6e449a3a 1707 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
3280af22 1708 PUSHs(&PL_sv_yes);
06a5b730 1709 }
811a4de9
GS
1710 /* eval BLOCK (try blocks have old_namesv == 0) */
1711 else {
1712 PUSHs(&PL_sv_undef);
1713 PUSHs(&PL_sv_undef);
1714 }
4633a7c4 1715 }
a682de96
GS
1716 else {
1717 PUSHs(&PL_sv_undef);
1718 PUSHs(&PL_sv_undef);
1719 }
bafb2adc 1720 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
ed094faf 1721 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1722 {
66a1b24b
AL
1723 AV * const ary = cx->blk_sub.argarray;
1724 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1725
3280af22 1726 if (!PL_dbargs) {
71315bf2 1727 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
0bd48802 1728 PL_dbargs = GvAV(gv_AVadd(tmpgv));
a5f75d66 1729 GvMULTI_on(tmpgv);
3ddcf04c 1730 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW
1731 }
1732
3280af22
NIS
1733 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1734 av_extend(PL_dbargs, AvFILLp(ary) + off);
1735 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1736 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1737 }
f3aa04c2
GS
1738 /* XXX only hints propagated via op_private are currently
1739 * visible (others are not easily accessible, since they
1740 * use the global PL_hints) */
6e449a3a 1741 mPUSHi(CopHINTS_get(cx->blk_oldcop));
e476b1b5
GS
1742 {
1743 SV * mask ;
72dc9ed5 1744 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1745
ac27b0f5 1746 if (old_warnings == pWARN_NONE ||
114bafba 1747 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1748 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1749 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS
1750 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1751 /* Get the bit mask for $warnings::Bits{all}, because
1752 * it could have been extended by warnings::register */
1753 SV **bits_all;
0bd48802 1754 HV * const bits = get_hv("warnings::Bits", FALSE);
017a3ce5 1755 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS
1756 mask = newSVsv(*bits_all);
1757 }
1758 else {
1759 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1760 }
1761 }
e476b1b5 1762 else
72dc9ed5 1763 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
6e449a3a 1764 mPUSHs(mask);
e476b1b5 1765 }
b3ca2e83 1766
c28fe1ec 1767 PUSHs(cx->blk_oldcop->cop_hints_hash ?
b3ca2e83 1768 sv_2mortal(newRV_noinc(
c28fe1ec
NC
1769 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1770 cx->blk_oldcop->cop_hints_hash)))
b3ca2e83 1771 : &PL_sv_undef);
a0d0e21e
LW
1772 RETURN;
1773}
1774
a0d0e21e
LW
1775PP(pp_reset)
1776{
97aff369 1777 dVAR;
39644a26 1778 dSP;
10edeb5d 1779 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
11faa288 1780 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1781 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1782 RETURN;
1783}
1784
dd2155a4
DM
1785/* like pp_nextstate, but used instead when the debugger is active */
1786
a0d0e21e
LW
1787PP(pp_dbstate)
1788{
27da23d5 1789 dVAR;
533c011a 1790 PL_curcop = (COP*)PL_op;
a0d0e21e 1791 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1792 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1793 FREETMPS;
1794
5df8de69
DM
1795 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1796 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1797 {
39644a26 1798 dSP;
c09156bb 1799 register PERL_CONTEXT *cx;
f54cb97a 1800 const I32 gimme = G_ARRAY;
eb160463 1801 U8 hasargs;
0bd48802
AL
1802 GV * const gv = PL_DBgv;
1803 register CV * const cv = GvCV(gv);
a0d0e21e 1804
a0d0e21e 1805 if (!cv)
cea2e8a9 1806 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1807
aea4f609
DM
1808 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1809 /* don't do recursive DB::DB call */
a0d0e21e 1810 return NORMAL;
748a9306 1811
4633a7c4
LW
1812 ENTER;
1813 SAVETMPS;
1814
3280af22 1815 SAVEI32(PL_debug);
55497cff 1816 SAVESTACK_POS();
3280af22 1817 PL_debug = 0;
748a9306 1818 hasargs = 0;
924508f0 1819 SPAGAIN;
748a9306 1820
aed2304a 1821 if (CvISXSUB(cv)) {
c127bd3a
SF
1822 CvDEPTH(cv)++;
1823 PUSHMARK(SP);
1824 (void)(*CvXSUB(cv))(aTHX_ cv);
1825 CvDEPTH(cv)--;
1826 FREETMPS;
1827 LEAVE;
1828 return NORMAL;
1829 }
1830 else {
1831 PUSHBLOCK(cx, CXt_SUB, SP);
1832 PUSHSUB_DB(cx);
1833 cx->blk_sub.retop = PL_op->op_next;
1834 CvDEPTH(cv)++;
1835 SAVECOMPPAD();
1836 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1837 RETURNOP(CvSTART(cv));
1838 }
a0d0e21e
LW
1839 }
1840 else
1841 return NORMAL;
1842}
1843
a0d0e21e
LW
1844PP(pp_enteriter)
1845{
27da23d5 1846 dVAR; dSP; dMARK;
c09156bb 1847 register PERL_CONTEXT *cx;
f54cb97a 1848 const I32 gimme = GIMME_V;
a0d0e21e 1849 SV **svp;
840fe433 1850 U8 cxtype = CXt_LOOP_FOR;
7766f137 1851#ifdef USE_ITHREADS
e846cb92 1852 PAD *iterdata;
7766f137 1853#endif
a0d0e21e 1854
4633a7c4
LW
1855 ENTER;
1856 SAVETMPS;
1857
533c011a 1858 if (PL_op->op_targ) {
14f338dc
DM
1859 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1860 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1861 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1862 SVs_PADSTALE, SVs_PADSTALE);
1863 }
09edbca0 1864 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
c3564e5c 1865#ifndef USE_ITHREADS
dd2155a4 1866 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
c3564e5c 1867#else
e846cb92 1868 iterdata = NULL;
7766f137 1869#endif
54b9620d
MB
1870 }
1871 else {
0bd48802 1872 GV * const gv = (GV*)POPs;
7766f137 1873 svp = &GvSV(gv); /* symbol table variable */
0214ae40 1874 SAVEGENERICSV(*svp);
561b68a9 1875 *svp = newSV(0);
7766f137 1876#ifdef USE_ITHREADS
e846cb92 1877 iterdata = (PAD*)gv;
7766f137 1878#endif
54b9620d 1879 }
4633a7c4 1880
0d863452
RH
1881 if (PL_op->op_private & OPpITER_DEF)
1882 cxtype |= CXp_FOR_DEF;
1883
a0d0e21e
LW
1884 ENTER;
1885
7766f137
GS
1886 PUSHBLOCK(cx, cxtype, SP);
1887#ifdef USE_ITHREADS
e846cb92 1888 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
7766f137 1889#else
52d1f6fb 1890 PUSHLOOP_FOR(cx, svp, MARK, 0);
7766f137 1891#endif
533c011a 1892 if (PL_op->op_flags & OPf_STACKED) {
d01136d6
BS
1893 SV *maybe_ary = POPs;
1894 if (SvTYPE(maybe_ary) != SVt_PVAV) {
89ea2908 1895 dPOPss;
d01136d6 1896 SV * const right = maybe_ary;
984a4bea
RD
1897 SvGETMAGIC(sv);
1898 SvGETMAGIC(right);
4fe3f0fa 1899 if (RANGE_IS_NUMERIC(sv,right)) {
d01136d6 1900 cx->cx_type &= ~CXTYPEMASK;
c6fdafd0
NC
1901 cx->cx_type |= CXt_LOOP_LAZYIV;
1902 /* Make sure that no-one re-orders cop.h and breaks our
1903 assumptions */
1904 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
a2309040
JH
1905#ifdef NV_PRESERVES_UV
1906 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1907 (SvNV(sv) > (NV)IV_MAX)))
1908 ||
1909 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1910 (SvNV(right) < (NV)IV_MIN))))
1911#else
1912 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1913 ||
1914 ((SvNV(sv) > 0) &&
1915 ((SvUV(sv) > (UV)IV_MAX) ||
1916 (SvNV(sv) > (NV)UV_MAX)))))
1917 ||
1918 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1919 ||
1920 ((SvNV(right) > 0) &&
1921 ((SvUV(right) > (UV)IV_MAX) ||
1922 (SvNV(right) > (NV)UV_MAX))))))
1923#endif
076d9a11 1924 DIE(aTHX_ "Range iterator outside integer range");
d01136d6
BS
1925 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1926 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
d4665a05
DM
1927#ifdef DEBUGGING
1928 /* for correct -Dstv display */
1929 cx->blk_oldsp = sp - PL_stack_base;
1930#endif
89ea2908 1931 }
3f63a782 1932 else {
d01136d6
BS
1933 cx->cx_type &= ~CXTYPEMASK;
1934 cx->cx_type |= CXt_LOOP_LAZYSV;
1935 /* Make sure that no-one re-orders cop.h and breaks our
1936 assumptions */
1937 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1938 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1939 cx->blk_loop.state_u.lazysv.end = right;
1940 SvREFCNT_inc(right);
1941 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
267cc4a8
NC
1942 /* This will do the upgrade to SVt_PV, and warn if the value
1943 is uninitialised. */
10516c54 1944 (void) SvPV_nolen_const(right);
267cc4a8
NC
1945 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1946 to replace !SvOK() with a pointer to "". */
1947 if (!SvOK(right)) {
1948 SvREFCNT_dec(right);
d01136d6 1949 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
267cc4a8 1950 }
3f63a782 1951 }
89ea2908 1952 }
d01136d6
BS
1953 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1954 cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1955 SvREFCNT_inc(maybe_ary);
1956 cx->blk_loop.state_u.ary.ix =
1957 (PL_op->op_private & OPpITER_REVERSED) ?
1958 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1959 -1;
ef3e5ea9 1960 }
89ea2908 1961 }
d01136d6
BS
1962 else { /* iterating over items on the stack */
1963 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
ef3e5ea9 1964 if (PL_op->op_private & OPpITER_REVERSED) {
d01136d6 1965 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
ef3e5ea9
NC
1966 }
1967 else {
d01136d6 1968 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
ef3e5ea9 1969 }
4633a7c4 1970 }
a0d0e21e
LW
1971
1972 RETURN;
1973}
1974
1975PP(pp_enterloop)
1976{
27da23d5 1977 dVAR; dSP;
c09156bb 1978 register PERL_CONTEXT *cx;
f54cb97a 1979 const I32 gimme = GIMME_V;
a0d0e21e
LW
1980
1981 ENTER;
1982 SAVETMPS;
1983 ENTER;
1984
3b719c58
NC
1985 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1986 PUSHLOOP_PLAIN(cx, SP);
a0d0e21e
LW
1987
1988 RETURN;
1989}
1990
1991PP(pp_leaveloop)
1992{
27da23d5 1993 dVAR; dSP;
c09156bb 1994 register PERL_CONTEXT *cx;
a0d0e21e
LW
1995 I32 gimme;
1996 SV **newsp;
1997 PMOP *newpm;
1998 SV **mark;
1999
2000 POPBLOCK(cx,newpm);
3b719c58 2001 assert(CxTYPE_is_LOOP(cx));
4fdae800 2002 mark = newsp;
a8bba7fa 2003 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 2004
a1f49e72 2005 TAINT_NOT;
54310121 2006 if (gimme == G_VOID)
6f207bd3 2007 NOOP;
54310121
PP
2008 else if (gimme == G_SCALAR) {
2009 if (mark < SP)
2010 *++newsp = sv_mortalcopy(*SP);
2011 else
3280af22 2012 *++newsp = &PL_sv_undef;
a0d0e21e
LW
2013 }
2014 else {
a1f49e72 2015 while (mark < SP) {
a0d0e21e 2016 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
2017 TAINT_NOT; /* Each item is independent */
2018 }
a0d0e21e 2019 }
f86702cc
PP
2020 SP = newsp;
2021 PUTBACK;
2022
a8bba7fa 2023 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 2024 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2025
a0d0e21e
LW
2026 LEAVE;
2027 LEAVE;
2028
f86702cc 2029 return NORMAL;
a0d0e21e
LW
2030}
2031
2032PP(pp_return)
2033{
27da23d5 2034 dVAR; dSP; dMARK;
c09156bb 2035 register PERL_CONTEXT *cx;
f86702cc 2036 bool popsub2 = FALSE;
b45de488 2037 bool clear_errsv = FALSE;
a0d0e21e
LW
2038 I32 gimme;
2039 SV **newsp;
2040 PMOP *newpm;
2041 I32 optype = 0;
b0d9ce38 2042 SV *sv;
f39bc417 2043 OP *retop;
a0d0e21e 2044
0bd48802
AL
2045 const I32 cxix = dopoptosub(cxstack_ix);
2046
9850bf21
RH
2047 if (cxix < 0) {
2048 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2049 * sort block, which is a CXt_NULL
2050 * not a CXt_SUB */
2051 dounwind(0);
d7507f74
RH
2052 PL_stack_base[1] = *PL_stack_sp;
2053 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
2054 return 0;
2055 }
9850bf21
RH
2056 else
2057 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 2058 }
a0d0e21e
LW
2059 if (cxix < cxstack_ix)
2060 dounwind(cxix);
2061
d7507f74
RH
2062 if (CxMULTICALL(&cxstack[cxix])) {
2063 gimme = cxstack[cxix].blk_gimme;
2064 if (gimme == G_VOID)
2065 PL_stack_sp = PL_stack_base;
2066 else if (gimme == G_SCALAR) {
2067 PL_stack_base[1] = *PL_stack_sp;
2068 PL_stack_sp = PL_stack_base + 1;
2069 }
9850bf21 2070 return 0;
d7507f74 2071 }
9850bf21 2072
a0d0e21e 2073 POPBLOCK(cx,newpm);
6b35e009 2074 switch (CxTYPE(cx)) {
a0d0e21e 2075 case CXt_SUB:
f86702cc 2076 popsub2 = TRUE;
f39bc417 2077 retop = cx->blk_sub.retop;
5dd42e15 2078 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW
2079 break;
2080 case CXt_EVAL:
b45de488
GS
2081 if (!(PL_in_eval & EVAL_KEEPERR))
2082 clear_errsv = TRUE;
a0d0e21e 2083 POPEVAL(cx);
f39bc417 2084 retop = cx->blk_eval.retop;
1d76a5c3
GS
2085 if (CxTRYBLOCK(cx))
2086 break;
067f92a0 2087 lex_end();
748a9306
LW
2088 if (optype == OP_REQUIRE &&
2089 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2090 {
54310121 2091 /* Unassume the success we assumed earlier. */
901017d6 2092 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 2093 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
be2597df 2094 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
748a9306 2095 }
a0d0e21e 2096 break;
7766f137
GS
2097 case CXt_FORMAT:
2098 POPFORMAT(cx);
f39bc417 2099 retop = cx->blk_sub.retop;
7766f137 2100 break;
a0d0e21e 2101 default:
cea2e8a9 2102 DIE(aTHX_ "panic: return");
a0d0e21e
LW
2103 }
2104
a1f49e72 2105 TAINT_NOT;
a0d0e21e 2106 if (gimme == G_SCALAR) {
a29cdaf0
IZ
2107 if (MARK < SP) {
2108 if (popsub2) {
a8bba7fa 2109 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2110 if (SvTEMP(TOPs)) {
2111 *++newsp = SvREFCNT_inc(*SP);
2112 FREETMPS;
2113 sv_2mortal(*newsp);
959e3673
GS
2114 }
2115 else {
2116 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2117 FREETMPS;
959e3673
GS
2118 *++newsp = sv_mortalcopy(sv);
2119 SvREFCNT_dec(sv);
a29cdaf0 2120 }
959e3673
GS
2121 }
2122 else
a29cdaf0 2123 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS
2124 }
2125 else
a29cdaf0 2126 *++newsp = sv_mortalcopy(*SP);
959e3673
GS
2127 }
2128 else
3280af22 2129 *++newsp = &PL_sv_undef;
a0d0e21e 2130 }
54310121 2131 else if (gimme == G_ARRAY) {
a1f49e72 2132 while (++MARK <= SP) {
f86702cc
PP
2133 *++newsp = (popsub2 && SvTEMP(*MARK))
2134 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2135 TAINT_NOT; /* Each item is independent */
2136 }
a0d0e21e 2137 }
3280af22 2138 PL_stack_sp = newsp;
a0d0e21e 2139
5dd42e15 2140 LEAVE;
f86702cc
PP
2141 /* Stack values are safe: */
2142 if (popsub2) {
5dd42e15 2143 cxstack_ix--;
b0d9ce38 2144 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2145 }
b0d9ce38 2146 else
c445ea15 2147 sv = NULL;
3280af22 2148 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2149
b0d9ce38 2150 LEAVESUB(sv);
8433848b 2151 if (clear_errsv) {
ab69dbc2 2152 CLEAR_ERRSV();
8433848b 2153 }
f39bc417 2154 return retop;
a0d0e21e
LW
2155}
2156
2157PP(pp_last)
2158{
27da23d5 2159 dVAR; dSP;
a0d0e21e 2160 I32 cxix;
c09156bb 2161 register PERL_CONTEXT *cx;
f86702cc 2162 I32 pop2 = 0;
a0d0e21e 2163 I32 gimme;
8772537c 2164 I32 optype;
a0d0e21e
LW
2165 OP *nextop;
2166 SV **newsp;
2167 PMOP *newpm;
a8bba7fa 2168 SV **mark;
c445ea15 2169 SV *sv = NULL;
9d4ba2ae 2170
a0d0e21e 2171
533c011a 2172 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2173 cxix = dopoptoloop(cxstack_ix);
2174 if (cxix < 0)
a651a37d 2175 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
2176 }
2177 else {
2178 cxix = dopoptolabel(cPVOP->op_pv);
2179 if (cxix < 0)
cea2e8a9 2180 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
2181 }
2182 if (cxix < cxstack_ix)
2183 dounwind(cxix);
2184
2185 POPBLOCK(cx,newpm);
5dd42e15 2186 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2187 mark = newsp;
6b35e009 2188 switch (CxTYPE(cx)) {
c6fdafd0 2189 case CXt_LOOP_LAZYIV:
d01136d6 2190 case CXt_LOOP_LAZYSV:
3b719c58
NC
2191 case CXt_LOOP_FOR:
2192 case CXt_LOOP_PLAIN:
2193 pop2 = CxTYPE(cx);
a8bba7fa 2194 newsp = PL_stack_base + cx->blk_loop.resetsp;
022eaa24 2195 nextop = cx->blk_loop.my_op->op_lastop->op_next;
a0d0e21e 2196 break;
f86702cc 2197 case CXt_SUB:
f86702cc 2198 pop2 = CXt_SUB;
f39bc417 2199 nextop = cx->blk_sub.retop;
a0d0e21e 2200 break;
f86702cc
PP
2201 case CXt_EVAL:
2202 POPEVAL(cx);
f39bc417 2203 nextop = cx->blk_eval.retop;
a0d0e21e 2204 break;
7766f137
GS
2205 case CXt_FORMAT:
2206 POPFORMAT(cx);
f39bc417 2207 nextop = cx->blk_sub.retop;
7766f137 2208 break;
a0d0e21e 2209 default:
cea2e8a9 2210 DIE(aTHX_ "panic: last");
a0d0e21e
LW
2211 }
2212
a1f49e72 2213 TAINT_NOT;
a0d0e21e 2214 if (gimme == G_SCALAR) {
f86702cc
PP
2215 if (MARK < SP)
2216 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2217 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2218 else
3280af22 2219 *++newsp = &PL_sv_undef;
a0d0e21e 2220 }
54310121 2221 else if (gimme == G_ARRAY) {
a1f49e72 2222 while (++MARK <= SP) {
f86702cc
PP
2223 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2224 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
2225 TAINT_NOT; /* Each item is independent */
2226 }
f86702cc
PP
2227 }
2228 SP = newsp;
2229 PUTBACK;
2230
5dd42e15
DM
2231 LEAVE;
2232 cxstack_ix--;
f86702cc
PP
2233 /* Stack values are safe: */
2234 switch (pop2) {
c6fdafd0 2235 case CXt_LOOP_LAZYIV:
3b719c58 2236 case CXt_LOOP_PLAIN:
d01136d6 2237 case CXt_LOOP_LAZYSV:
3b719c58 2238 case CXt_LOOP_FOR:
a8bba7fa 2239 POPLOOP(cx); /* release loop vars ... */
4fdae800 2240 LEAVE;
f86702cc
PP
2241 break;
2242 case CXt_SUB:
b0d9ce38 2243 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2244 break;
a0d0e21e 2245 }
3280af22 2246 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2247
b0d9ce38 2248 LEAVESUB(sv);
9d4ba2ae
AL
2249 PERL_UNUSED_VAR(optype);
2250 PERL_UNUSED_VAR(gimme);
f86702cc 2251 return nextop;
a0d0e21e
LW
2252}
2253
2254PP(pp_next)
2255{
27da23d5 2256 dVAR;
a0d0e21e 2257 I32 cxix;
c09156bb 2258 register PERL_CONTEXT *cx;
85538317 2259 I32 inner;
a0d0e21e 2260
533c011a 2261 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2262 cxix = dopoptoloop(cxstack_ix);
2263 if (cxix < 0)
a651a37d 2264 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
2265 }
2266 else {
2267 cxix = dopoptolabel(cPVOP->op_pv);
2268 if (cxix < 0)
cea2e8a9 2269 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
2270 }
2271 if (cxix < cxstack_ix)
2272 dounwind(cxix);
2273
85538317
GS
2274 /* clear off anything above the scope we're re-entering, but
2275 * save the rest until after a possible continue block */
2276 inner = PL_scopestack_ix;
1ba6ee2b 2277 TOPBLOCK(cx);
85538317
GS
2278 if (PL_scopestack_ix < inner)
2279 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2280 PL_curcop = cx->blk_oldcop;
022eaa24 2281 return CX_LOOP_NEXTOP_GET(cx);
a0d0e21e
LW
2282}
2283
2284PP(pp_redo)
2285{
27da23d5 2286 dVAR;
a0d0e21e 2287 I32 cxix;
c09156bb 2288 register PERL_CONTEXT *cx;
a0d0e21e 2289 I32 oldsave;
a034e688 2290 OP* redo_op;
a0d0e21e 2291
533c011a 2292 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2293 cxix = dopoptoloop(cxstack_ix);
2294 if (cxix < 0)
a651a37d 2295 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
2296 }
2297 else {
2298 cxix = dopoptolabel(cPVOP->op_pv);
2299 if (cxix < 0)
cea2e8a9 2300 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
2301 }
2302 if (cxix < cxstack_ix)
2303 dounwind(cxix);
2304
022eaa24 2305 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
a034e688
DM
2306 if (redo_op->op_type == OP_ENTER) {
2307 /* pop one less context to avoid $x being freed in while (my $x..) */
2308 cxstack_ix++;
2309 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2310 redo_op = redo_op->op_next;
2311 }
2312
a0d0e21e 2313 TOPBLOCK(cx);
3280af22 2314 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2315 LEAVE_SCOPE(oldsave);
936c78b5 2316 FREETMPS;
3a1b2b9e 2317 PL_curcop = cx->blk_oldcop;
a034e688 2318 return redo_op;
a0d0e21e
LW
2319}
2320
0824fdcb 2321STATIC OP *
bfed75c6 2322S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2323{
97aff369 2324 dVAR;
a0d0e21e 2325 OP **ops = opstack;
bfed75c6 2326 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2327
7918f24d
NC
2328 PERL_ARGS_ASSERT_DOFINDLABEL;
2329
fc36a67e 2330 if (ops >= oplimit)
cea2e8a9 2331 Perl_croak(aTHX_ too_deep);
11343788
MB
2332 if (o->op_type == OP_LEAVE ||
2333 o->op_type == OP_SCOPE ||
2334 o->op_type == OP_LEAVELOOP ||
33d34e4c 2335 o->op_type == OP_LEAVESUB ||
11343788 2336 o->op_type == OP_LEAVETRY)
fc36a67e 2337 {
5dc0d613 2338 *ops++ = cUNOPo->op_first;
fc36a67e 2339 if (ops >= oplimit)
cea2e8a9 2340 Perl_croak(aTHX_ too_deep);
fc36a67e 2341 }
c4aa4e48 2342 *ops = 0;
11343788 2343 if (o->op_flags & OPf_KIDS) {
aec46f14 2344 OP *kid;
a0d0e21e 2345 /* First try all the kids at this level, since that's likeliest. */
11343788 2346 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48 2347 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
4b65a919 2348 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
a0d0e21e
LW
2349 return kid;
2350 }
11343788 2351 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2352 if (kid == PL_lastgotoprobe)
a0d0e21e 2353 continue;
ed8d0fe2
SM
2354 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2355 if (ops == opstack)
2356 *ops++ = kid;
2357 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2358 ops[-1]->op_type == OP_DBSTATE)
2359 ops[-1] = kid;
2360 else
2361 *ops++ = kid;
2362 }
155aba94 2363 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2364 return o;
a0d0e21e
LW
2365 }
2366 }
c4aa4e48 2367 *ops = 0;
a0d0e21e
LW
2368 return 0;
2369}
2370
a0d0e21e
LW
2371PP(pp_goto)
2372{
27da23d5 2373 dVAR; dSP;
cbbf8932 2374 OP *retop = NULL;
a0d0e21e 2375 I32 ix;
c09156bb 2376 register PERL_CONTEXT *cx;
fc36a67e
PP
2377#define GOTO_DEPTH 64
2378 OP *enterops[GOTO_DEPTH];
cbbf8932 2379 const char *label = NULL;
bfed75c6
AL
2380 const bool do_dump = (PL_op->op_type == OP_DUMP);
2381 static const char must_have_label[] = "goto must have label";
a0d0e21e 2382
533c011a 2383 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2384 SV * const sv = POPs;
a0d0e21e
LW
2385
2386 /* This egregious kludge implements goto &subroutine */
2387 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2388 I32 cxix;
c09156bb 2389 register PERL_CONTEXT *cx;
a0d0e21e
LW
2390 CV* cv = (CV*)SvRV(sv);
2391 SV** mark;
2392 I32 items = 0;
2393 I32 oldsave;
b1464ded 2394 bool reified = 0;
a0d0e21e 2395
e8f7dd13 2396 retry:
4aa0a1f7 2397 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2398 const GV * const gv = CvGV(cv);
e8f7dd13 2399 if (gv) {
7fc63493 2400 GV *autogv;
e8f7dd13
GS
2401 SV *tmpstr;
2402 /* autoloaded stub? */
2403 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2404 goto retry;
2405 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2406 GvNAMELEN(gv), FALSE);
2407 if (autogv && (cv = GvCV(autogv)))
2408 goto retry;
2409 tmpstr = sv_newmortal();
c445ea15 2410 gv_efullname3(tmpstr, gv, NULL);
be2597df 2411 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
4aa0a1f7 2412 }
cea2e8a9 2413 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2414 }
2415
a0d0e21e 2416 /* First do some returnish stuff. */
b37c2d43 2417 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
71fc2216 2418 FREETMPS;
a0d0e21e
LW
2419 cxix = dopoptosub(cxstack_ix);
2420 if (cxix < 0)
cea2e8a9 2421 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2422 if (cxix < cxstack_ix)
2423 dounwind(cxix);
2424 TOPBLOCK(cx);
2d43a17f 2425 SPAGAIN;
564abe23 2426 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2427 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM
2428 if (CxREALEVAL(cx))
2429 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2430 else
2431 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2432 }
9850bf21
RH
2433 else if (CxMULTICALL(cx))
2434 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
bafb2adc 2435 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
d8b46c1b 2436 /* put @_ back onto stack */
a0d0e21e 2437 AV* av = cx->blk_sub.argarray;
bfed75c6 2438
93965878 2439 items = AvFILLp(av) + 1;
a45cdc79
DM
2440 EXTEND(SP, items+1); /* @_ could have been extended. */
2441 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS
2442 SvREFCNT_dec(GvAV(PL_defgv));
2443 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2444 CLEAR_ARGARRAY(av);
d8b46c1b 2445 /* abandon @_ if it got reified */
62b1ebc2 2446 if (AvREAL(av)) {
b1464ded
DM
2447 reified = 1;
2448 SvREFCNT_dec(av);
d8b46c1b
GS
2449 av = newAV();
2450 av_extend(av, items-1);
11ca45c0 2451 AvREIFY_only(av);
dd2155a4 2452 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2453 }
a0d0e21e 2454 }
aed2304a 2455 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2456 AV* const av = GvAV(PL_defgv);
1fa4e549 2457 items = AvFILLp(av) + 1;
a45cdc79
DM
2458 EXTEND(SP, items+1); /* @_ could have been extended. */
2459 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2460 }
a45cdc79
DM
2461 mark = SP;
2462 SP += items;
6b35e009 2463 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2464 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2465 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2466 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2467 LEAVE_SCOPE(oldsave);
2468
2469 /* Now do some callish stuff. */
2470 SAVETMPS;
5023d17a 2471 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2472 if (CvISXSUB(cv)) {
b37c2d43 2473 OP* const retop = cx->blk_sub.retop;
f73ef291
NC
2474 SV **newsp;
2475 I32 gimme;
b1464ded
DM
2476 if (reified) {
2477 I32 index;
2478 for (index=0; index<items; index++)
2479 sv_2mortal(SP[-index]);
2480 }
1fa4e549 2481
b37c2d43
AL
2482 /* XS subs don't have a CxSUB, so pop it */
2483 POPBLOCK(cx, PL_curpm);
2484 /* Push a mark for the start of arglist */
2485 PUSHMARK(mark);
2486 PUTBACK;
2487 (void)(*CvXSUB(cv))(aTHX_ cv);
a0d0e21e 2488 LEAVE;
5eff7df7 2489 return retop;
a0d0e21e
LW
2490 }
2491 else {
b37c2d43 2492 AV* const padlist = CvPADLIST(cv);
6b35e009 2493 if (CxTYPE(cx) == CXt_EVAL) {
85a64632 2494 PL_in_eval = CxOLD_IN_EVAL(cx);
3280af22 2495 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22 2496 cx->cx_type = CXt_SUB;
b150fb22 2497 }
a0d0e21e 2498 cx->blk_sub.cv = cv;
1a5b3db4 2499 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2500
a0d0e21e
LW
2501 CvDEPTH(cv)++;
2502 if (CvDEPTH(cv) < 2)
74c765eb 2503 SvREFCNT_inc_simple_void_NN(cv);
dd2155a4 2504 else {
2b9dff67 2505 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
44a8e56a 2506 sub_crush_depth(cv);
26019298 2507 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2508 }
fd617465
DM
2509 SAVECOMPPAD();
2510 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
bafb2adc 2511 if (CxHASARGS(cx))
6d4ff0d2 2512 {
b37c2d43 2513 AV* const av = (AV*)PAD_SVl(0);
a0d0e21e 2514
3280af22 2515 cx->blk_sub.savearray = GvAV(PL_defgv);
b37c2d43 2516 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
dd2155a4 2517 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2518 cx->blk_sub.argarray = av;
a0d0e21e
LW
2519
2520 if (items >= AvMAX(av) + 1) {
b37c2d43 2521 SV **ary = AvALLOC(av);
a0d0e21e
LW
2522 if (AvARRAY(av) != ary) {
2523 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2524 AvARRAY(av) = ary;
a0d0e21e
LW
2525 }
2526 if (items >= AvMAX(av) + 1) {
2527 AvMAX(av) = items - 1;
2528 Renew(ary,items+1,SV*);
2529 AvALLOC(av) = ary;
9c6bc640 2530 AvARRAY(av) = ary;
a0d0e21e
LW
2531 }
2532 }
a45cdc79 2533 ++mark;
a0d0e21e 2534 Copy(mark,AvARRAY(av),items,SV*);
93965878 2535 AvFILLp(av) = items - 1;
d8b46c1b 2536 assert(!AvREAL(av));
b1464ded
DM
2537 if (reified) {
2538 /* transfer 'ownership' of refcnts to new @_ */
2539 AvREAL_on(av);
2540 AvREIFY_off(av);
2541 }
a0d0e21e
LW
2542 while (items--) {
2543 if (*mark)
2544 SvTEMP_off(*mark);
2545 mark++;
2546 }
2547 }
491527d0 2548 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
005a8a35 2549 Perl_get_db_sub(aTHX_ NULL, cv);
b37c2d43
AL
2550 if (PERLDB_GOTO) {
2551 CV * const gotocv = get_cv("DB::goto", FALSE);
2552 if (gotocv) {
2553 PUSHMARK( PL_stack_sp );
2554 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2555 PL_stack_sp--;
2556 }
491527d0 2557 }
1ce6579f 2558 }
a0d0e21e
LW
2559 RETURNOP(CvSTART(cv));
2560 }
2561 }
1614b0e3 2562 else {
0510663f 2563 label = SvPV_nolen_const(sv);
1614b0e3 2564 if (!(do_dump || *label))
cea2e8a9 2565 DIE(aTHX_ must_have_label);
1614b0e3 2566 }
a0d0e21e 2567 }
533c011a 2568 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2569 if (! do_dump)
cea2e8a9 2570 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2571 }
2572 else
2573 label = cPVOP->op_pv;
2574
2575 if (label && *label) {
cbbf8932 2576 OP *gotoprobe = NULL;
3b2447bc 2577 bool leaving_eval = FALSE;
33d34e4c 2578 bool in_block = FALSE;
cbbf8932 2579 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW
2580
2581 /* find label */
2582
d4c19fe8 2583 PL_lastgotoprobe = NULL;
a0d0e21e
LW
2584 *enterops = 0;
2585 for (ix = cxstack_ix; ix >= 0; ix--) {
2586 cx = &cxstack[ix];
6b35e009 2587 switch (CxTYPE(cx)) {
a0d0e21e 2588 case CXt_EVAL:
3b2447bc 2589 leaving_eval = TRUE;
971ecbe6 2590 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH
2591 gotoprobe = (last_eval_cx ?
2592 last_eval_cx->blk_eval.old_eval_root :
2593 PL_eval_root);
2594 last_eval_cx = cx;
9c5794fe
RH
2595 break;
2596 }
2597 /* else fall through */
c6fdafd0 2598 case CXt_LOOP_LAZYIV:
d01136d6 2599 case CXt_LOOP_LAZYSV:
3b719c58
NC
2600 case CXt_LOOP_FOR:
2601 case CXt_LOOP_PLAIN:
a0d0e21e
LW
2602 gotoprobe = cx->blk_oldcop->op_sibling;
2603 break;
2604 case CXt_SUBST:
2605 continue;
2606 case CXt_BLOCK:
33d34e4c 2607 if (ix) {
a0d0e21e 2608 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE
2609 in_block = TRUE;
2610 } else
3280af22 2611 gotoprobe = PL_main_root;
a0d0e21e 2612 break;
b3933176 2613 case CXt_SUB:
9850bf21 2614 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS
2615 gotoprobe = CvROOT(cx->blk_sub.cv);
2616 break;
2617 }
2618 /* FALL THROUGH */
7766f137 2619 case CXt_FORMAT:
0a753a76 2620 case CXt_NULL:
a651a37d 2621 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2622 default:
2623 if (ix)
cea2e8a9 2624 DIE(aTHX_ "panic: goto");
3280af22 2625 gotoprobe = PL_main_root;
a0d0e21e
LW
2626 break;
2627 }
2b597662
GS
2628 if (gotoprobe) {
2629 retop = dofindlabel(gotoprobe, label,
2630 enterops, enterops + GOTO_DEPTH);
2631 if (retop)
2632 break;
2633 }
3280af22 2634 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2635 }
2636 if (!retop)
cea2e8a9 2637 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2638
3b2447bc
RH
2639 /* if we're leaving an eval, check before we pop any frames
2640 that we're not going to punt, otherwise the error
2641 won't be caught */
2642
2643 if (leaving_eval && *enterops && enterops[1]) {
2644 I32 i;
2645 for (i = 1; enterops[i]; i++)
2646 if (enterops[i]->op_type == OP_ENTERITER)
2647 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2648 }
2649
a0d0e21e
LW
2650 /* pop unwanted frames */
2651
2652 if (ix < cxstack_ix) {
2653 I32 oldsave;
2654
2655 if (ix < 0)
2656 ix = 0;
2657 dounwind(ix);
2658 TOPBLOCK(cx);
3280af22 2659 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2660 LEAVE_SCOPE(oldsave);
2661 }
2662
2663 /* push wanted frames */
2664
748a9306 2665 if (*enterops && enterops[1]) {
0bd48802 2666 OP * const oldop = PL_op;
33d34e4c
AE
2667 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2668 for (; enterops[ix]; ix++) {
533c011a 2669 PL_op = enterops[ix];
84902520
TB
2670 /* Eventually we may want to stack the needed arguments
2671 * for each op. For now, we punt on the hard ones. */
533c011a 2672 if (PL_op->op_type == OP_ENTERITER)
894356b3 2673 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2674 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2675 }
533c011a 2676 PL_op = oldop;
a0d0e21e
LW
2677 }
2678 }
2679
2680 if (do_dump) {
a5f75d66 2681#ifdef VMS
6b88bc9c 2682 if (!retop) retop = PL_main_start;
a5f75d66 2683#endif
3280af22
NIS
2684 PL_restartop = retop;
2685 PL_do_undump = TRUE;
a0d0e21e
LW
2686
2687 my_unexec();
2688
3280af22
NIS
2689 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2690 PL_do_undump = FALSE;
a0d0e21e
LW
2691 }
2692
2693 RETURNOP(retop);
2694}
2695
2696PP(pp_exit)
2697{
97aff369 2698 dVAR;
39644a26 2699 dSP;
a0d0e21e
LW
2700 I32 anum;
2701
2702 if (MAXARG < 1)
2703 anum = 0;
ff0cee69 2704 else {
a0d0e21e 2705 anum = SvIVx(POPs);
d98f61e7
GS
2706#ifdef VMS
2707 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2708 anum = 0;
96e176bf 2709 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69
PP
2710#endif
2711 }
cc3604b1 2712 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC
2713#ifdef PERL_MAD
2714 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2715 if (anum || !(PL_minus_c && PL_madskills))
2716 my_exit(anum);
2717#else
a0d0e21e 2718 my_exit(anum);
81d86705 2719#endif
3280af22 2720 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2721 RETURN;
2722}
2723
a0d0e21e
LW
2724/* Eval. */
2725
0824fdcb 2726STATIC void
cea2e8a9 2727S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2728{
504618e9 2729 const char *s = SvPVX_const(sv);
890ce7af 2730 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2731 I32 line = 1;
a0d0e21e 2732
7918f24d
NC
2733 PERL_ARGS_ASSERT_SAVE_LINES;
2734
a0d0e21e 2735 while (s && s < send) {
f54cb97a 2736 const char *t;
b9f83d2f 2737 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 2738
a0d0e21e
LW
2739 t = strchr(s, '\n');
2740 if (t)
2741 t++;
2742 else
2743 t = send;
2744
2745 sv_setpvn(tmpstr, s, t - s);
2746 av_store(array, line++, tmpstr);
2747 s = t;
2748 }
2749}
2750
0824fdcb 2751STATIC OP *
cea2e8a9 2752S_docatch(pTHX_ OP *o)
1e422769 2753{
97aff369 2754 dVAR;
6224f72b 2755 int ret;
06b5626a 2756 OP * const oldop = PL_op;
db36c5a1 2757 dJMPENV;
1e422769 2758
1e422769 2759#ifdef DEBUGGING
54310121 2760 assert(CATCH_GET == TRUE);
1e422769 2761#endif
312caa8e 2762 PL_op = o;
8bffa5f8 2763
14dd3ad8 2764 JMPENV_PUSH(ret);
6224f72b 2765 switch (ret) {
312caa8e 2766 case 0:
abd70938
DM
2767 assert(cxstack_ix >= 0);
2768 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2769 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8 2770 redo_body:
85aaa934 2771 CALLRUNOPS(aTHX);
312caa8e
CS
2772 break;
2773 case 3:
8bffa5f8 2774 /* die caught by an inner eval - continue inner loop */
abd70938
DM
2775
2776 /* NB XXX we rely on the old popped CxEVAL still being at the top
2777 * of the stack; the way die_where() currently works, this
2778 * assumption is valid. In theory The cur_top_env value should be
2779 * returned in another global, the way retop (aka PL_restartop)
2780 * is. */
2781 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2782
2783 if (PL_restartop
2784 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2785 {
312caa8e
CS
2786 PL_op = PL_restartop;
2787 PL_restartop = 0;
2788 goto redo_body;
2789 }
2790 /* FALL THROUGH */
2791 default:
14dd3ad8 2792 JMPENV_POP;
533c011a 2793 PL_op = oldop;
6224f72b 2794 JMPENV_JUMP(ret);
1e422769 2795 /* NOTREACHED */
1e422769 2796 }
14dd3ad8 2797 JMPENV_POP;
533c011a 2798 PL_op = oldop;
5f66b61c 2799 return NULL;
1e422769
PP
2800}
2801
c277df42 2802OP *
bfed75c6 2803Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ
2804/* sv Text to convert to OP tree. */
2805/* startop op_free() this to undo. */
2806/* code Short string id of the caller. */
2807{
f7997f86 2808 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2809 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ
2810 PERL_CONTEXT *cx;
2811 SV **newsp;
b094c71d 2812 I32 gimme = G_VOID;
c277df42
IZ
2813 I32 optype;
2814 OP dummy;
83ee9e09
GS
2815 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2816 char *tmpbuf = tbuf;
c277df42 2817 char *safestr;
a3985cdc 2818 int runtime;
601f1833 2819 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 2820 STRLEN len;
c277df42 2821
7918f24d
NC
2822 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2823
c277df42 2824 ENTER;
5486870f 2825 lex_start(sv, NULL, FALSE);
c277df42
IZ
2826 SAVETMPS;
2827 /* switch to eval mode */
2828
923e4eb5 2829 if (IN_PERL_COMPILETIME) {
f4dd75d9 2830 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2831 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2832 }
83ee9e09 2833 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2834 SV * const sv = sv_newmortal();
83ee9e09
GS
2835 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2836 code, (unsigned long)++PL_evalseq,
2837 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2838 tmpbuf = SvPVX(sv);
fc009855 2839 len = SvCUR(sv);
83ee9e09
GS
2840 }
2841 else
d9fad198
JH
2842 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2843 (unsigned long)++PL_evalseq);
f4dd75d9 2844 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2845 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2846 SAVECOPLINE(&PL_compiling);
57843af0 2847 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2848 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2849 deleting the eval's FILEGV from the stash before gv_check() runs
2850 (i.e. before run-time proper). To work around the coredump that
2851 ensues, we always turn GvMULTI_on for any globals that were
2852 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC
2853 safestr = savepvn(tmpbuf, len);
2854 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2855 SAVEHINTS();
d1ca3daa 2856#ifdef OP_IN_REGISTER
6b88bc9c 2857 PL_opsave = op;
d1ca3daa 2858#else
7766f137 2859 SAVEVPTR(PL_op);
d1ca3daa 2860#endif
c277df42 2861
a3985cdc 2862 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2863 runtime = IN_PERL_RUNTIME;
a3985cdc 2864 if (runtime)
d819b83a 2865 runcv = find_runcv(NULL);
a3985cdc 2866
533c011a 2867 PL_op = &dummy;
13b51b79 2868 PL_op->op_type = OP_ENTEREVAL;
533c011a 2869 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2870 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
6b75f042 2871 PUSHEVAL(cx, 0);
a3985cdc
DM
2872
2873 if (runtime)
410be5db 2874 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
a3985cdc 2875 else
410be5db 2876 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2877 POPBLOCK(cx,PL_curpm);
e84b9f1f 2878 POPEVAL(cx);
c277df42
IZ
2879
2880 (*startop)->op_type = OP_NULL;
22c35a8c 2881 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2882 lex_end();
f3548bdc 2883 /* XXX DAPM do this properly one year */
b37c2d43 2884 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
c277df42 2885 LEAVE;
923e4eb5 2886 if (IN_PERL_COMPILETIME)
623e6609 2887 CopHINTS_set(&PL_compiling, PL_hints);
d1ca3daa 2888#ifdef OP_IN_REGISTER
6b88bc9c 2889 op = PL_opsave;
d1ca3daa 2890#endif
9d4ba2ae
AL
2891 PERL_UNUSED_VAR(newsp);
2892 PERL_UNUSED_VAR(optype);
2893
410be5db 2894 return PL_eval_start;
c277df42
IZ
2895}
2896
a3985cdc
DM
2897
2898/*
2899=for apidoc find_runcv
2900
2901Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM
2902If db_seqp is non_null, skip CVs that are in the DB package and populate
2903*db_seqp with the cop sequence number at the point that the DB:: code was
2904entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2905than in the scope of the debugger itself).
a3985cdc
DM
2906
2907=cut
2908*/
2909
2910CV*
d819b83a 2911Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2912{
97aff369 2913 dVAR;
a3985cdc 2914 PERL_SI *si;
a3985cdc 2915
d819b83a
DM
2916 if (db_seqp)
2917 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2918 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2919 I32 ix;
a3985cdc 2920 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2921 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2922 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2923 CV * const cv = cx->blk_sub.cv;
d819b83a
DM
2924 /* skip DB:: code */
2925 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2926 *db_seqp = cx->blk_oldcop->cop_seq;
2927 continue;
2928 }
2929 return cv;
2930 }
a3985cdc
DM
2931 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2932 return PL_compcv;
2933 }
2934 }
2935 return PL_main_cv;
2936}
2937
2938
2939/* Compile a require/do, an eval '', or a /(?{...})/.
2940 * In the last case, startop is non-null, and contains the address of
2941 * a pointer that should be set to the just-compiled code.
2942 * outside is the lexically enclosing CV (if any) that invoked us.
410be5db
DM
2943 * Returns a bool indicating whether the compile was successful; if so,
2944 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2945 * pushes undef (also croaks if startop != NULL).
a3985cdc
DM
2946 */
2947
410be5db 2948STATIC bool
a3985cdc 2949S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2950{
27da23d5 2951 dVAR; dSP;
46c461b5 2952 OP * const saveop = PL_op;
a0d0e21e 2953
6dc8a9e4
IZ
2954 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2955 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2956 : EVAL_INEVAL);
a0d0e21e 2957
1ce6579f
PP
2958 PUSHMARK(SP);
2959
3280af22 2960 SAVESPTR(PL_compcv);
b9f83d2f 2961 PL_compcv = (CV*)newSV_type(SVt_PVCV);
1aff0e91 2962 CvEVAL_on(PL_compcv);
2090ab20
JH
2963 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2964 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2965
a3985cdc 2966 CvOUTSIDE_SEQ(PL_compcv) = seq;
b37c2d43 2967 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
a3985cdc 2968
dd2155a4 2969 /* set up a scratch pad */
a0d0e21e 2970
dd2155a4 2971 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
cecbe010 2972 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2c05e328 2973
07055b4c 2974
81d86705
NC
2975 if (!PL_madskills)
2976 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2977
a0d0e21e
LW
2978 /* make sure we compile in the right package */
2979
ed094faf 2980 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2981 SAVESPTR(PL_curstash);
ed094faf 2982 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2983 }
3c10abe3 2984 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3280af22
NIS
2985 SAVESPTR(PL_beginav);
2986 PL_beginav = newAV();
2987 SAVEFREESV(PL_beginav);
3c10abe3
AG
2988 SAVESPTR(PL_unitcheckav);
2989 PL_unitcheckav = newAV();
2990 SAVEFREESV(PL_unitcheckav);
a0d0e21e 2991
81d86705 2992#ifdef PERL_MAD
9da243ce 2993 SAVEBOOL(PL_madskills);
81d86705
NC
2994 PL_madskills = 0;
2995#endif
2996
a0d0e21e
LW
2997 /* try to compile it */
2998
5f66b61c 2999 PL_eval_root = NULL;
3280af22 3000 PL_curcop = &PL_compiling;
fc15ae8f 3001 CopARYBASE_set(PL_curcop, 0);
5f66b61c 3002 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 3003 PL_in_eval |= EVAL_KEEPERR;
ab69dbc2
RGS
3004 else
3005 CLEAR_ERRSV();
13765c85 3006 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
0c58d367 3007 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 3008 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 3009 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 3010 const char *msg;
bfed75c6 3011
533c011a 3012 PL_op = saveop;
3280af22
NIS
3013 if (PL_eval_root) {
3014 op_free(PL_eval_root);
5f66b61c 3015 PL_eval_root = NULL;
a0d0e21e 3016 }
3280af22 3017 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 3018 if (!startop) {
3280af22 3019 POPBLOCK(cx,PL_curpm);
c277df42 3020 POPEVAL(cx);
c277df42 3021 }
a0d0e21e
LW
3022 lex_end();
3023 LEAVE;
9d4ba2ae
AL
3024
3025 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 3026 if (optype == OP_REQUIRE) {
b464bac0 3027 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 3028 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 3029 &PL_sv_undef, 0);
58d3fd3b
SH
3030 Perl_croak(aTHX_ "%sCompilation failed in require",
3031 *msg ? msg : "Unknown error\n");
5a844595
GS
3032 }
3033 else if (startop) {
3280af22 3034 POPBLOCK(cx,PL_curpm);
c277df42 3035 POPEVAL(cx);
5a844595
GS
3036 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3037 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 3038 }
9d7f88dd 3039 else {
9d7f88dd 3040 if (!*msg) {
6502358f 3041 sv_setpvs(ERRSV, "Compilation error");
9d7f88dd
SR
3042 }
3043 }
9d4ba2ae 3044 PERL_UNUSED_VAR(newsp);
410be5db
DM
3045 PUSHs(&PL_sv_undef);
3046 PUTBACK;
3047 return FALSE;
a0d0e21e 3048 }
57843af0 3049 CopLINE_set(&PL_compiling, 0);
c277df42 3050 if (startop) {
3280af22 3051 *startop = PL_eval_root;
c277df42 3052 } else
3280af22 3053 SAVEFREEOP(PL_eval_root);
0c58d367
RGS
3054
3055 /* Set the context for this new optree.
3056 * If the last op is an OP_REQUIRE, force scalar context.
3057 * Otherwise, propagate the context from the eval(). */
3058 if (PL_eval_root->op_type == OP_LEAVEEVAL
3059 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3060 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3061 == OP_REQUIRE)
3062 scalar(PL_eval_root);
7df0357e 3063 else if ((gimme & G_WANT) == G_VOID)
3280af22 3064 scalarvoid(PL_eval_root);
7df0357e 3065 else if ((gimme & G_WANT) == G_ARRAY)
3280af22 3066 list(PL_eval_root);
a0d0e21e 3067 else
3280af22 3068 scalar(PL_eval_root);
a0d0e21e
LW
3069
3070 DEBUG_x(dump_eval());
3071
55497cff 3072 /* Register with debugger: */
6482a30d 3073 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
890ce7af 3074 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff
PP
3075 if (cv) {
3076 dSP;
924508f0 3077 PUSHMARK(SP);
cc49e20b 3078 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 3079 PUTBACK;
864dbfa3 3080 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
3081 }
3082 }
3083
3c10abe3
AG
3084 if (PL_unitcheckav)
3085 call_list(PL_scopestack_ix, PL_unitcheckav);
3086
a0d0e21e
LW
3087 /* compiled okay, so do it */
3088
3280af22
NIS
3089 CvDEPTH(PL_compcv) = 1;
3090 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3091 PL_op = saveop; /* The caller may need it. */
bc177e6b 3092 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3093
410be5db
DM
3094 PUTBACK;
3095 return TRUE;
a0d0e21e
LW
3096}
3097
a6c40364 3098STATIC PerlIO *
0786552a 3099S_check_type_and_open(pTHX_ const char *name)
ce8abf5f
SP
3100{
3101 Stat_t st;
c445ea15 3102 const int st_rc = PerlLIO_stat(name, &st);
df528165 3103
7918f24d
NC
3104 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3105
6b845e56 3106 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
4608196e 3107 return NULL;
ce8abf5f
SP
3108 }
3109
0786552a 3110 return PerlIO_open(name, PERL_SCRIPT_MODE);
ce8abf5f
SP
3111}
3112
75c20bac 3113#ifndef PERL_DISABLE_PMC
ce8abf5f 3114STATIC PerlIO *
0786552a 3115S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
b295d113 3116{
b295d113
TH
3117 PerlIO *fp;
3118
7918f24d
NC
3119 PERL_ARGS_ASSERT_DOOPEN_PM;
3120
ce9440c8 3121 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
50b8ed39
NC
3122 SV *const pmcsv = newSV(namelen + 2);
3123 char *const pmc = SvPVX(pmcsv);
a6c40364 3124 Stat_t pmcstat;
50b8ed39
NC
3125
3126 memcpy(pmc, name, namelen);
3127 pmc[namelen] = 'c';
3128 pmc[namelen + 1] = '\0';
3129
a6c40364 3130 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
0786552a 3131 fp = check_type_and_open(name);
a6c40364
GS
3132 }
3133 else {
0786552a 3134 fp = check_type_and_open(pmc);
b295d113 3135 }
a6c40364
GS
3136 SvREFCNT_dec(pmcsv);
3137 }
3138 else {
0786552a 3139 fp = check_type_and_open(name);
b295d113 3140 }
b295d113 3141 return fp;
75c20bac 3142}
7925835c 3143#else
75c20bac 3144# define doopen_pm(name, namelen) check_type_and_open(name)
7925835c 3145#endif /* !PERL_DISABLE_PMC */
b295d113 3146
a0d0e21e
LW
3147PP(pp_require)
3148{
27da23d5 3149 dVAR; dSP;
c09156bb 3150 register PERL_CONTEXT *cx;
a0d0e21e 3151 SV *sv;
5c144d81 3152 const char *name;
6132ea6c 3153 STRLEN len;
4492be7a
JM
3154 char * unixname;
3155 STRLEN unixlen;
62f5ad7a 3156#ifdef VMS
4492be7a 3157 int vms_unixname = 0;
62f5ad7a 3158#endif
c445ea15
AL
3159 const char *tryname = NULL;
3160 SV *namesv = NULL;
f54cb97a 3161 const I32 gimme = GIMME_V;
bbed91b5 3162 int filter_has_file = 0;
c445ea15 3163 PerlIO *tryrsfp = NULL;
34113e50 3164 SV *filter_cache = NULL;
c445ea15
AL
3165 SV *filter_state = NULL;
3166 SV *filter_sub = NULL;
3167 SV *hook_sv = NULL;
6ec9efec
JH
3168 SV *encoding;
3169 OP *op;
a0d0e21e
LW
3170
3171 sv = POPs;
d7aa5382 3172 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
d7aa5382
JP
3173 sv = new_version(sv);
3174 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3175 upg_version(PL_patchlevel, TRUE);
149c1637 3176 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3cacfbb9 3177 if ( vcmp(sv,PL_patchlevel) <= 0 )
468aa647 3178 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
be2597df 3179 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
468aa647
RGS
3180 }
3181 else {
d1029faa
JP
3182 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3183 I32 first = 0;
3184 AV *lav;
3185 SV * const req = SvRV(sv);
3186 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3187
3188 /* get the left hand term */
3189 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3190
3191 first = SvIV(*av_fetch(lav,0,0));
3192 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3193 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3194 || av_len(lav) > 1 /* FP with > 3 digits */
3195 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3196 ) {
3197 DIE(aTHX_ "Perl %"SVf" required--this is only "
3198 "%"SVf", stopped", SVfARG(vnormal(req)),
3199 SVfARG(vnormal(PL_patchlevel)));
3200 }
3201 else { /* probably 'use 5.10' or 'use 5.8' */
3202 SV * hintsv = newSV(0);
3203 I32 second = 0;
3204
3205 if (av_len(lav)>=1)
3206 second = SvIV(*av_fetch(lav,1,0));
3207
3208 second /= second >= 600 ? 100 : 10;
3209 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3210 (int)first, (int)second,0);
3211 upg_version(hintsv, TRUE);
3212
3213 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3214 "--this is only %"SVf", stopped",
3215 SVfARG(vnormal(req)),
3216 SVfARG(vnormal(hintsv)),
3217 SVfARG(vnormal(PL_patchlevel)));
3218 }
3219 }
468aa647 3220 }
d7aa5382 3221
fbc891ce
RB
3222 /* We do this only with use, not require. */
3223 if (PL_compcv &&
fbc891ce
RB
3224 /* If we request a version >= 5.9.5, load feature.pm with the
3225 * feature bundle that corresponds to the required version. */
2e8342de 3226 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
7dfde25d
RGS
3227 SV *const importsv = vnormal(sv);
3228 *SvPVX_mutable(importsv) = ':';
3229 ENTER;
3230 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3231 LEAVE;
3232 }
3233
3234 RETPUSHYES;
a0d0e21e 3235 }
5c144d81 3236 name = SvPV_const(sv, len);
6132ea6c 3237 if (!(name && len > 0 && *name))
cea2e8a9 3238 DIE(aTHX_ "Null filename used");
4633a7c4 3239 TAINT_PROPER("require");
4492be7a
JM
3240
3241
3242#ifdef VMS
3243 /* The key in the %ENV hash is in the syntax of file passed as the argument
3244 * usually this is in UNIX format, but sometimes in VMS format, which
3245 * can result in a module being pulled in more than once.
3246 * To prevent this, the key must be stored in UNIX format if the VMS
3247 * name can be translated to UNIX.
3248 */
3249 if ((unixname = tounixspec(name, NULL)) != NULL) {
3250 unixlen = strlen(unixname);
3251 vms_unixname = 1;
3252 }
3253 else
3254#endif
3255 {
3256 /* if not VMS or VMS name can not be translated to UNIX, pass it
3257 * through.
3258 */
3259 unixname = (char *) name;
3260 unixlen = len;
3261 }
44f8325f 3262 if (PL_op->op_type == OP_REQUIRE) {
4492be7a
JM
3263 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3264 unixname, unixlen, 0);
44f8325f
AL
3265 if ( svp ) {
3266 if (*svp != &PL_sv_undef)
3267 RETPUSHYES;
3268 else
087b5369
RD
3269 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3270 "Compilation failed in require", unixname);
44f8325f 3271 }
4d8b06f1 3272 }
a0d0e21e
LW
3273
3274 /* prepare to compile file */
3275
be4b629d 3276 if (path_is_absolute(name)) {
46fc3d4c 3277 tryname = name;
0786552a 3278 tryrsfp = doopen_pm(name, len);
bf4acbe4 3279 }
67627c52
JH
3280#ifdef MACOS_TRADITIONAL
3281 if (!tryrsfp) {
3282 char newname[256];
3283
3284 MacPerl_CanonDir(name, newname, 1);
3285 if (path_is_absolute(newname)) {
3286 tryname = newname;
0786552a 3287 tryrsfp = doopen_pm(newname, strlen(newname));
67627c52
JH
3288 }
3289 }
3290#endif
be4b629d 3291 if (!tryrsfp) {
44f8325f 3292 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3293 I32 i;
748a9306 3294#ifdef VMS
4492be7a 3295 if (vms_unixname)
46fc3d4c
PP
3296#endif
3297 {
d0328fd7 3298 namesv = newSV_type(SVt_PV);
46fc3d4c 3299 for (i = 0; i <= AvFILL(ar); i++) {
df528165 3300 SV * const dirsv = *av_fetch(ar, i, TRUE);
bbed91b5 3301
c38a6530
RD
3302 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3303 mg_get(dirsv);
bbed91b5
KF
3304 if (SvROK(dirsv)) {
3305 int count;
a3b58a99 3306 SV **svp;
bbed91b5
KF
3307 SV *loader = dirsv;
3308
e14e2dc8
NC
3309 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3310 && !sv_isobject(loader))
3311 {
bbed91b5
KF
3312 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3313 }
3314
b900a521 3315 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3316 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3317 tryname = SvPVX_const(namesv);
c445ea15 3318 tryrsfp = NULL;
bbed91b5
KF
3319
3320 ENTER;
3321 SAVETMPS;
3322 EXTEND(SP, 2);
3323
3324 PUSHMARK(SP);
3325 PUSHs(dirsv);
3326 PUSHs(sv);
3327 PUTBACK;
e982885c
NC
3328 if (sv_isobject(loader))
3329 count = call_method("INC", G_ARRAY);
3330 else
3331 count = call_sv(loader, G_ARRAY);
bbed91b5
KF
3332 SPAGAIN;
3333
a3b58a99
RGS
3334 /* Adjust file name if the hook has set an %INC entry */
3335 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3336 if (svp)
3337 tryname = SvPVX_const(*svp);
3338
bbed91b5
KF
3339 if (count > 0) {
3340 int i = 0;
3341 SV *arg;
3342
3343 SP -= count - 1;
3344 arg = SP[i++];
3345
34113e50
NC
3346 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3347 && !isGV_with_GP(SvRV(arg))) {
3348 filter_cache = SvRV(arg);
74c765eb 3349 SvREFCNT_inc_simple_void_NN(filter_cache);
34113e50
NC
3350
3351 if (i < count) {
3352 arg = SP[i++];
3353 }
3354 }
3355
6e592b3a 3356 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
bbed91b5
KF
3357 arg = SvRV(arg);
3358 }
3359
6e592b3a 3360 if (isGV_with_GP(arg)) {
df528165 3361 IO * const io = GvIO((GV *)arg);
bbed91b5
KF
3362
3363 ++filter_has_file;
3364
3365 if (io) {
3366 tryrsfp = IoIFP(io);
0f7de14d
NC
3367 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3368 PerlIO_close(IoOFP(io));
bbed91b5 3369 }
0f7de14d
NC
3370 IoIFP(io) = NULL;
3371 IoOFP(io) = NULL;
bbed91b5
KF
3372 }
3373
3374 if (i < count) {
3375 arg = SP[i++];
3376 }
3377 }
3378
3379 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3380 filter_sub = arg;
74c765eb 3381 SvREFCNT_inc_simple_void_NN(filter_sub);
bbed91b5
KF
3382
3383 if (i < count) {
3384 filter_state = SP[i];
b37c2d43 3385 SvREFCNT_inc_simple_void(filter_state);
bbed91b5 3386 }
34113e50 3387 }
bbed91b5 3388
34113e50
NC
3389 if (!tryrsfp && (filter_cache || filter_sub)) {
3390 tryrsfp = PerlIO_open(BIT_BUCKET,
3391 PERL_SCRIPT_MODE);
bbed91b5 3392 }
1d06aecd 3393 SP--;
bbed91b5
KF
3394 }
3395
3396 PUTBACK;
3397 FREETMPS;
3398 LEAVE;
3399
3400 if (tryrsfp) {
89ccab8c 3401 hook_sv = dirsv;
bbed91b5
KF
3402 break;
3403 }
3404
3405 filter_has_file = 0;
34113e50
NC
3406 if (filter_cache) {
3407 SvREFCNT_dec(filter_cache);
3408 filter_cache = NULL;
3409 }
bbed91b5
KF
3410 if (filter_state) {
3411 SvREFCNT_dec(filter_state);
c445ea15 3412 filter_state = NULL;
bbed91b5
KF
3413 }
3414 if (filter_sub) {
3415 SvREFCNT_dec(filter_sub);