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