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
For an LVALUE fetch, "hv_fetch()" will recurse into "hv_store()" for a
[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
a0d0e21e
LW		 41PP(pp_wantarray)
42{
97aff369 43 dVAR;
39644a26 44 dSP;
a0d0e21e
LW		 45 I32 cxix;
46 EXTEND(SP, 1);
47
48 cxix = dopoptosub(cxstack_ix);
49 if (cxix < 0)
50 RETPUSHUNDEF;
51
54310121 52 switch (cxstack[cxix].blk_gimme) {
53 case G_ARRAY:
a0d0e21e 54 RETPUSHYES;
54310121 55 case G_SCALAR:
a0d0e21e 56 RETPUSHNO;
54310121 57 default:
58 RETPUSHUNDEF;
59 }
a0d0e21e
LW		 60}
61
2cd61cdb
IZ		 62PP(pp_regcreset)
63{
97aff369 64 dVAR;
2cd61cdb
IZ		 65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
3280af22 67 PL_reginterp_cnt = 0;
0b4182de 68 TAINT_NOT;
2cd61cdb
IZ		 69 return NORMAL;
70}
71
b3eb6a9b
GS		 72PP(pp_regcomp)
73{
97aff369 74 dVAR;
39644a26 75 dSP;
a0d0e21e 76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
a0d0e21e 77 SV *tmpstr;
4608196e 78 MAGIC *mg = NULL;
c737faaf 79 regexp * re;
bfed75c6 80
4b5a0d1c 81 /* prevent recompiling under /o and ithreads. */
3db8f154 82#if defined(USE_ITHREADS)
131b3ad0
DM		 83 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
84 if (PL_op->op_flags & OPf_STACKED) {
85 dMARK;
86 SP = MARK;
87 }
88 else
89 (void)POPs;
90 RETURN;
91 }
513629ba 92#endif
131b3ad0
DM		 93 if (PL_op->op_flags & OPf_STACKED) {
94 /* multiple args; concatentate them */
95 dMARK; dORIGMARK;
96 tmpstr = PAD_SV(ARGTARG);
97 sv_setpvn(tmpstr, "", 0);
98 while (++MARK <= SP) {
99 if (PL_amagic_generation) {
100 SV *sv;
101 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
102 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
103 {
104 sv_setsv(tmpstr, sv);
105 continue;
106 }
107 }
108 sv_catsv(tmpstr, *MARK);
109 }
110 SvSETMAGIC(tmpstr);
111 SP = ORIGMARK;
112 }
113 else
114 tmpstr = POPs;
513629ba 115
b3eb6a9b 116 if (SvROK(tmpstr)) {
d8f6592e 117 SV * const sv = SvRV(tmpstr);
c277df42 118 if(SvMAGICAL(sv))
14befaf4 119 mg = mg_find(sv, PERL_MAGIC_qr);
c277df42 120 }
b3eb6a9b 121 if (mg) {
28d8d7f4 122 regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
aaa362c4 123 ReREFCNT_dec(PM_GETRE(pm));
28d8d7f4 124 PM_SETRE(pm, re);
c277df42
IZ		 125 }
126 else {
e62f0680 127 STRLEN len;
3ab4a224 128 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
c737faaf 129 re = PM_GETRE(pm);
c277df42 130
20408e3c 131 /* Check against the last compiled regexp. */
d8f6592e
AL		 132 if (!re || !re->precomp || re->prelen != (I32)len ||
133 memNE(re->precomp, t, len))
85aff577 134 {
664e119d 135 const regexp_engine *eng = re ? re->engine : NULL;
c737faaf 136 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
d8f6592e
AL		 137 if (re) {
138 ReREFCNT_dec(re);
4608196e 139 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
1e2e3d02
YO		 140 } else if (PL_curcop->cop_hints_hash) {
141 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
142 "regcomp", 7, 0, 0);
143 if (ptr && SvIOK(ptr) && SvIV(ptr))
144 eng = INT2PTR(regexp_engine*,SvIV(ptr));
c277df42 145 }
664e119d 146
533c011a 147 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 148 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 149
84e09d5e 150 if (DO_UTF8(tmpstr))
c737faaf
YO		 151 pm_flags |= RXf_UTF8;
152
3ab4a224
AB		 153 if (eng)
154 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
155 else
156 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
c737faaf 157
f86aaa29 158 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 159 inside tie/overload accessors. */
c277df42 160 }
4633a7c4 161 }
c737faaf
YO		 162
163 re = PM_GETRE(pm);
a0d0e21e 164
72311751 165#ifndef INCOMPLETE_TAINTS
3280af22
NIS		 166 if (PL_tainting) {
167 if (PL_tainted)
c737faaf 168 re->extflags |= RXf_TAINTED;
72311751 169 else
c737faaf 170 re->extflags &= ~RXf_TAINTED;
72311751
GS		 171 }
172#endif
173
aaa362c4 174 if (!PM_GETRE(pm)->prelen && PL_curpm)
3280af22 175 pm = PL_curpm;
a0d0e21e 176
c737faaf
YO		 177
178#if !defined(USE_ITHREADS)
179 /* can't change the optree at runtime either */
180 /* PMf_KEEP is handled differently under threads to avoid these problems */
a0d0e21e 181 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 182 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
533c011a 183 cLOGOP->op_first->op_next = PL_op->op_next;
a0d0e21e 184 }
c737faaf 185#endif
a0d0e21e
LW		 186 RETURN;
187}
188
189PP(pp_substcont)
190{
97aff369 191 dVAR;
39644a26 192 dSP;
c09156bb 193 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
901017d6
AL		 194 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
195 register SV * const dstr = cx->sb_dstr;
a0d0e21e
LW		 196 register char *s = cx->sb_s;
197 register char *m = cx->sb_m;
198 char *orig = cx->sb_orig;
901017d6 199 register REGEXP * const rx = cx->sb_rx;
c445ea15 200 SV *nsv = NULL;
988e6e7e
AE		 201 REGEXP *old = PM_GETRE(pm);
202 if(old != rx) {
bfed75c6 203 if(old)
988e6e7e 204 ReREFCNT_dec(old);
e22ae1e2 205 PM_SETRE(pm,ReREFCNT_inc(rx));
d8f2cf8a
AB		 206 }
207
d9f97599 208 rxres_restore(&cx->sb_rxres, rx);
01b35787 209 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
c90c0ff4 210
a0d0e21e 211 if (cx->sb_iters++) {
a3b680e6 212 const I32 saviters = cx->sb_iters;
a0d0e21e 213 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 214 DIE(aTHX_ "Substitution loop");
a0d0e21e 215
48c036b1
GS		 216 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
217 cx->sb_rxtainted |= 2;
a0d0e21e 218 sv_catsv(dstr, POPs);
8ff629d9 219 FREETMPS; /* Prevent excess tmp stack */
a0d0e21e
LW		 220
221 /* Are we done */
f9f4320a 222 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
9661b544 223 s == m, cx->sb_targ, NULL,
22e551b9 224 ((cx->sb_rflags & REXEC_COPY_STR)
cf93c79d
IZ		 225 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
226 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e 227 {
823a54a3 228 SV * const targ = cx->sb_targ;
748a9306 229
078c425b
JH		 230 assert(cx->sb_strend >= s);
231 if(cx->sb_strend > s) {
232 if (DO_UTF8(dstr) && !SvUTF8(targ))
233 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
234 else
235 sv_catpvn(dstr, s, cx->sb_strend - s);
236 }
48c036b1 237 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 238
f8c7b90f 239#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 240 if (SvIsCOW(targ)) {
241 sv_force_normal_flags(targ, SV_COW_DROP_PV);
242 } else
243#endif
244 {
8bd4d4c5 245 SvPV_free(targ);
ed252734 246 }
f880fe2f 247 SvPV_set(targ, SvPVX(dstr));
748a9306
LW		 248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
1aa99e6b
IH		 250 if (DO_UTF8(dstr))
251 SvUTF8_on(targ);
6136c704 252 SvPV_set(dstr, NULL);
48c036b1
GS		 253
254 TAINT_IF(cx->sb_rxtainted & 1);
22e13caa 255 PUSHs(sv_2mortal(newSViv(saviters - 1)));
48c036b1 256
ffc61ed2 257 (void)SvPOK_only_UTF8(targ);
48c036b1 258 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 259 SvSETMAGIC(targ);
9212bbba 260 SvTAINT(targ);
5cd24f17 261
4633a7c4 262 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW		 263 POPSUBST(cx);
264 RETURNOP(pm->op_next);
265 }
8e5e9ebe 266 cx->sb_iters = saviters;
a0d0e21e 267 }
cf93c79d 268 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 269 m = s;
270 s = orig;
cf93c79d 271 cx->sb_orig = orig = rx->subbeg;
a0d0e21e
LW		 272 s = orig + (m - s);
273 cx->sb_strend = s + (cx->sb_strend - m);
274 }
f0ab9afb 275 cx->sb_m = m = rx->offs[0].start + orig;
db79b45b 276 if (m > s) {
bfed75c6 277 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
db79b45b
JH		 278 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
279 else
280 sv_catpvn(dstr, s, m-s);
281 }
f0ab9afb 282 cx->sb_s = rx->offs[0].end + orig;
084916e3 283 { /* Update the pos() information. */
44f8325f 284 SV * const sv = cx->sb_targ;
084916e3
JH		 285 MAGIC *mg;
286 I32 i;
7a7f3e45 287 SvUPGRADE(sv, SVt_PVMG);
14befaf4 288 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
d83f0a82 289#ifdef PERL_OLD_COPY_ON_WRITE
51a9ea20 290 if (SvIsCOW(sv))
d83f0a82
NC		 291 sv_force_normal_flags(sv, 0);
292#endif
293 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
294 NULL, 0);
084916e3
JH		 295 }
296 i = m - orig;
297 if (DO_UTF8(sv))
298 sv_pos_b2u(sv, &i);
299 mg->mg_len = i;
300 }
988e6e7e 301 if (old != rx)
454f1e26 302 (void)ReREFCNT_inc(rx);
d9f97599
GS		 303 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
304 rxres_save(&cx->sb_rxres, rx);
29f2e912 305 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
a0d0e21e
LW		 306}
307
c90c0ff4 308void
864dbfa3 309Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 310{
311 UV *p = (UV*)*rsp;
312 U32 i;
96a5add6 313 PERL_UNUSED_CONTEXT;
c90c0ff4 314
d9f97599 315 if (!p || p[1] < rx->nparens) {
f8c7b90f 316#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 317 i = 7 + rx->nparens * 2;
318#else
d9f97599 319 i = 6 + rx->nparens * 2;
ed252734 320#endif
c90c0ff4 321 if (!p)
a02a5408 322 Newx(p, i, UV);
c90c0ff4 323 else
324 Renew(p, i, UV);
325 *rsp = (void*)p;
326 }
327
c445ea15 328 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
cf93c79d 329 RX_MATCH_COPIED_off(rx);
c90c0ff4 330
f8c7b90f 331#ifdef PERL_OLD_COPY_ON_WRITE
ed252734 332 *p++ = PTR2UV(rx->saved_copy);
c445ea15 333 rx->saved_copy = NULL;
ed252734
NC		 334#endif
335
d9f97599 336 *p++ = rx->nparens;
c90c0ff4 337
56431972 338 *p++ = PTR2UV(rx->subbeg);
cf93c79d 339 *p++ = (UV)rx->sublen;
d9f97599 340 for (i = 0; i <= rx->nparens; ++i) {
f0ab9afb
NC		 341 *p++ = (UV)rx->offs[i].start;
342 *p++ = (UV)rx->offs[i].end;
c90c0ff4 343 }
344}
345
346void
864dbfa3 347Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 348{
349 UV *p = (UV*)*rsp;
350 U32 i;
96a5add6 351 PERL_UNUSED_CONTEXT;
c90c0ff4 352
ed252734 353 RX_MATCH_COPY_FREE(rx);
cf93c79d 354 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4 355 *p++ = 0;
356
f8c7b90f 357#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 358 if (rx->saved_copy)
359 SvREFCNT_dec (rx->saved_copy);
360 rx->saved_copy = INT2PTR(SV*,*p);
361 *p++ = 0;
362#endif
363
d9f97599 364 rx->nparens = *p++;
c90c0ff4 365
56431972 366 rx->subbeg = INT2PTR(char*,*p++);
cf93c79d 367 rx->sublen = (I32)(*p++);
d9f97599 368 for (i = 0; i <= rx->nparens; ++i) {
f0ab9afb
NC		 369 rx->offs[i].start = (I32)(*p++);
370 rx->offs[i].end = (I32)(*p++);
c90c0ff4 371 }
372}
373
374void
864dbfa3 375Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 376{
44f8325f 377 UV * const p = (UV*)*rsp;
96a5add6 378 PERL_UNUSED_CONTEXT;
c90c0ff4 379
380 if (p) {
94010e71
NC		 381#ifdef PERL_POISON
382 void *tmp = INT2PTR(char*,*p);
383 Safefree(tmp);
384 if (*p)
7e337ee0 385 PoisonFree(*p, 1, sizeof(*p));
94010e71 386#else
56431972 387 Safefree(INT2PTR(char*,*p));
94010e71 388#endif
f8c7b90f 389#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 390 if (p[1]) {
391 SvREFCNT_dec (INT2PTR(SV*,p[1]));
392 }
393#endif
c90c0ff4 394 Safefree(p);
4608196e 395 *rsp = NULL;
c90c0ff4 396 }
397}
398
a0d0e21e
LW		 399PP(pp_formline)
400{
97aff369 401 dVAR; dSP; dMARK; dORIGMARK;
823a54a3 402 register SV * const tmpForm = *++MARK;
dea28490 403 register U32 *fpc;
a0d0e21e 404 register char *t;
245d4a47 405 const char *f;
a0d0e21e 406 register I32 arg;
c445ea15
AL		 407 register SV *sv = NULL;
408 const char *item = NULL;
9c5ffd7c
JH		 409 I32 itemsize = 0;
410 I32 fieldsize = 0;
a0d0e21e 411 I32 lines = 0;
c445ea15
AL		 412 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
413 const char *chophere = NULL;
414 char *linemark = NULL;
65202027 415 NV value;
9c5ffd7c 416 bool gotsome = FALSE;
a0d0e21e 417 STRLEN len;
823a54a3 418 const STRLEN fudge = SvPOK(tmpForm)
24c89738 419 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
1bd51a4c
IH		 420 bool item_is_utf8 = FALSE;
421 bool targ_is_utf8 = FALSE;
c445ea15 422 SV * nsv = NULL;
cbbf8932 423 OP * parseres = NULL;
bfed75c6 424 const char *fmt;
a1b95068 425 bool oneline;
a0d0e21e 426
76e3520e 427 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445b3f51
GS		 428 if (SvREADONLY(tmpForm)) {
429 SvREADONLY_off(tmpForm);
a1b95068 430 parseres = doparseform(tmpForm);
445b3f51
GS		 431 SvREADONLY_on(tmpForm);
432 }
433 else
a1b95068
WL		 434 parseres = doparseform(tmpForm);
435 if (parseres)
436 return parseres;
a0d0e21e 437 }
3280af22 438 SvPV_force(PL_formtarget, len);
1bd51a4c
IH		 439 if (DO_UTF8(PL_formtarget))
440 targ_is_utf8 = TRUE;
a0ed51b3 441 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 442 t += len;
245d4a47 443 f = SvPV_const(tmpForm, len);
a0d0e21e 444 /* need to jump to the next word */
245d4a47 445 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
a0d0e21e
LW		 446
447 for (;;) {
448 DEBUG_f( {
bfed75c6 449 const char *name = "???";
a0d0e21e
LW		 450 arg = -1;
451 switch (*fpc) {
452 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
453 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
454 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
455 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
456 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
457
458 case FF_CHECKNL: name = "CHECKNL"; break;
459 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
460 case FF_SPACE: name = "SPACE"; break;
461 case FF_HALFSPACE: name = "HALFSPACE"; break;
462 case FF_ITEM: name = "ITEM"; break;
463 case FF_CHOP: name = "CHOP"; break;
464 case FF_LINEGLOB: name = "LINEGLOB"; break;
465 case FF_NEWLINE: name = "NEWLINE"; break;
466 case FF_MORE: name = "MORE"; break;
467 case FF_LINEMARK: name = "LINEMARK"; break;
468 case FF_END: name = "END"; break;
bfed75c6 469 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 470 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW		 471 }
472 if (arg >= 0)
bf49b057 473 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 474 else
bf49b057 475 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 476 } );
a0d0e21e
LW		 477 switch (*fpc++) {
478 case FF_LINEMARK:
479 linemark = t;
a0d0e21e
LW		 480 lines++;
481 gotsome = FALSE;
482 break;
483
484 case FF_LITERAL:
485 arg = *fpc++;
1bd51a4c 486 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
b15aece3 487 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
78da4d13
JH		 488 *t = '\0';
489 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
490 t = SvEND(PL_formtarget);
1bd51a4c
IH		 491 break;
492 }
493 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
b15aece3 494 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 495 *t = '\0';
496 sv_utf8_upgrade(PL_formtarget);
497 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
498 t = SvEND(PL_formtarget);
499 targ_is_utf8 = TRUE;
500 }
a0d0e21e
LW		 501 while (arg--)
502 *t++ = *f++;
503 break;
504
505 case FF_SKIP:
506 f += *fpc++;
507 break;
508
509 case FF_FETCH:
510 arg = *fpc++;
511 f += arg;
512 fieldsize = arg;
513
514 if (MARK < SP)
515 sv = *++MARK;
516 else {
3280af22 517 sv = &PL_sv_no;
599cee73 518 if (ckWARN(WARN_SYNTAX))
9014280d 519 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e
LW		 520 }
521 break;
522
523 case FF_CHECKNL:
5a34cab7
NC		 524 {
525 const char *send;
526 const char *s = item = SvPV_const(sv, len);
527 itemsize = len;
528 if (DO_UTF8(sv)) {
529 itemsize = sv_len_utf8(sv);
530 if (itemsize != (I32)len) {
531 I32 itembytes;
532 if (itemsize > fieldsize) {
533 itemsize = fieldsize;
534 itembytes = itemsize;
535 sv_pos_u2b(sv, &itembytes, 0);
536 }
537 else
538 itembytes = len;
539 send = chophere = s + itembytes;
540 while (s < send) {
541 if (*s & ~31)
542 gotsome = TRUE;
543 else if (*s == '\n')
544 break;
545 s++;
546 }
547 item_is_utf8 = TRUE;
548 itemsize = s - item;
549 sv_pos_b2u(sv, &itemsize);
550 break;
a0ed51b3 551 }
a0ed51b3 552 }
5a34cab7
NC		 553 item_is_utf8 = FALSE;
554 if (itemsize > fieldsize)
555 itemsize = fieldsize;
556 send = chophere = s + itemsize;
557 while (s < send) {
558 if (*s & ~31)
559 gotsome = TRUE;
560 else if (*s == '\n')
561 break;
562 s++;
563 }
564 itemsize = s - item;
565 break;
a0ed51b3 566 }
a0d0e21e
LW		 567
568 case FF_CHECKCHOP:
5a34cab7
NC		 569 {
570 const char *s = item = SvPV_const(sv, len);
571 itemsize = len;
572 if (DO_UTF8(sv)) {
573 itemsize = sv_len_utf8(sv);
574 if (itemsize != (I32)len) {
575 I32 itembytes;
576 if (itemsize <= fieldsize) {
577 const char *send = chophere = s + itemsize;
578 while (s < send) {
579 if (*s == '\r') {
580 itemsize = s - item;
a0ed51b3 581 chophere = s;
a0ed51b3 582 break;
5a34cab7
NC		 583 }
584 if (*s++ & ~31)
a0ed51b3 585 gotsome = TRUE;
a0ed51b3 586 }
a0ed51b3 587 }
5a34cab7
NC		 588 else {
589 const char *send;
590 itemsize = fieldsize;
591 itembytes = itemsize;
592 sv_pos_u2b(sv, &itembytes, 0);
593 send = chophere = s + itembytes;
594 while (s < send || (s == send && isSPACE(*s))) {
595 if (isSPACE(*s)) {
596 if (chopspace)
597 chophere = s;
598 if (*s == '\r')
599 break;
600 }
601 else {
602 if (*s & ~31)
603 gotsome = TRUE;
604 if (strchr(PL_chopset, *s))
605 chophere = s + 1;
606 }
607 s++;
608 }
609 itemsize = chophere - item;
610 sv_pos_b2u(sv, &itemsize);
611 }
612 item_is_utf8 = TRUE;
a0d0e21e
LW		 613 break;
614 }
a0d0e21e 615 }
5a34cab7
NC		 616 item_is_utf8 = FALSE;
617 if (itemsize <= fieldsize) {
618 const char *const send = chophere = s + itemsize;
619 while (s < send) {
620 if (*s == '\r') {
621 itemsize = s - item;
a0d0e21e 622 chophere = s;
a0d0e21e 623 break;
5a34cab7
NC		 624 }
625 if (*s++ & ~31)
a0d0e21e 626 gotsome = TRUE;
a0d0e21e 627 }
a0d0e21e 628 }
5a34cab7
NC		 629 else {
630 const char *send;
631 itemsize = fieldsize;
632 send = chophere = s + itemsize;
633 while (s < send || (s == send && isSPACE(*s))) {
634 if (isSPACE(*s)) {
635 if (chopspace)
636 chophere = s;
637 if (*s == '\r')
638 break;
639 }
640 else {
641 if (*s & ~31)
642 gotsome = TRUE;
643 if (strchr(PL_chopset, *s))
644 chophere = s + 1;
645 }
646 s++;
647 }
648 itemsize = chophere - item;
649 }
650 break;
a0d0e21e 651 }
a0d0e21e
LW		 652
653 case FF_SPACE:
654 arg = fieldsize - itemsize;
655 if (arg) {
656 fieldsize -= arg;
657 while (arg-- > 0)
658 *t++ = ' ';
659 }
660 break;
661
662 case FF_HALFSPACE:
663 arg = fieldsize - itemsize;
664 if (arg) {
665 arg /= 2;
666 fieldsize -= arg;
667 while (arg-- > 0)
668 *t++ = ' ';
669 }
670 break;
671
672 case FF_ITEM:
5a34cab7
NC		 673 {
674 const char *s = item;
675 arg = itemsize;
676 if (item_is_utf8) {
677 if (!targ_is_utf8) {
678 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
679 *t = '\0';
680 sv_utf8_upgrade(PL_formtarget);
681 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
682 t = SvEND(PL_formtarget);
683 targ_is_utf8 = TRUE;
a0ed51b3 684 }
5a34cab7
NC		 685 while (arg--) {
686 if (UTF8_IS_CONTINUED(*s)) {
687 STRLEN skip = UTF8SKIP(s);
688 switch (skip) {
689 default:
690 Move(s,t,skip,char);
691 s += skip;
692 t += skip;
693 break;
694 case 7: *t++ = *s++;
695 case 6: *t++ = *s++;
696 case 5: *t++ = *s++;
697 case 4: *t++ = *s++;
698 case 3: *t++ = *s++;
699 case 2: *t++ = *s++;
700 case 1: *t++ = *s++;
701 }
702 }
703 else {
704 if ( !((*t++ = *s++) & ~31) )
705 t[-1] = ' ';
706 }
a0ed51b3 707 }
5a34cab7 708 break;
a0ed51b3 709 }
5a34cab7
NC		 710 if (targ_is_utf8 && !item_is_utf8) {
711 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
712 *t = '\0';
713 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
714 for (; t < SvEND(PL_formtarget); t++) {
78da4d13 715#ifdef EBCDIC
901017d6 716 const int ch = *t;
5a34cab7 717 if (iscntrl(ch))
78da4d13 718#else
5a34cab7 719 if (!(*t & ~31))
78da4d13 720#endif
5a34cab7
NC		 721 *t = ' ';
722 }
723 break;
78da4d13 724 }
5a34cab7 725 while (arg--) {
9d116dd7 726#ifdef EBCDIC
901017d6 727 const int ch = *t++ = *s++;
5a34cab7 728 if (iscntrl(ch))
a0d0e21e 729#else
5a34cab7 730 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 731#endif
5a34cab7
NC		 732 t[-1] = ' ';
733 }
734 break;
a0d0e21e 735 }
a0d0e21e
LW		 736
737 case FF_CHOP:
5a34cab7
NC		 738 {
739 const char *s = chophere;
740 if (chopspace) {
af68e756 741 while (isSPACE(*s))
5a34cab7
NC		 742 s++;
743 }
744 sv_chop(sv,s);
745 SvSETMAGIC(sv);
746 break;
a0d0e21e 747 }
a0d0e21e 748
a1b95068
WL		 749 case FF_LINESNGL:
750 chopspace = 0;
751 oneline = TRUE;
752 goto ff_line;
a0d0e21e 753 case FF_LINEGLOB:
a1b95068
WL		 754 oneline = FALSE;
755 ff_line:
5a34cab7
NC		 756 {
757 const char *s = item = SvPV_const(sv, len);
758 itemsize = len;
759 if ((item_is_utf8 = DO_UTF8(sv)))
760 itemsize = sv_len_utf8(sv);
761 if (itemsize) {
762 bool chopped = FALSE;
763 const char *const send = s + len;
764 gotsome = TRUE;
765 chophere = s + itemsize;
766 while (s < send) {
767 if (*s++ == '\n') {
768 if (oneline) {
769 chopped = TRUE;
770 chophere = s;
771 break;
772 } else {
773 if (s == send) {
774 itemsize--;
775 chopped = TRUE;
776 } else
777 lines++;
778 }
1bd51a4c 779 }
a0d0e21e 780 }
5a34cab7
NC		 781 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
782 if (targ_is_utf8)
783 SvUTF8_on(PL_formtarget);
784 if (oneline) {
785 SvCUR_set(sv, chophere - item);
786 sv_catsv(PL_formtarget, sv);
787 SvCUR_set(sv, itemsize);
788 } else
789 sv_catsv(PL_formtarget, sv);
790 if (chopped)
791 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
792 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
793 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
794 if (item_is_utf8)
795 targ_is_utf8 = TRUE;
a0d0e21e 796 }
5a34cab7 797 break;
a0d0e21e 798 }
a0d0e21e 799
a1b95068
WL		 800 case FF_0DECIMAL:
801 arg = *fpc++;
802#if defined(USE_LONG_DOUBLE)
10edeb5d
JH		 803 fmt = (const char *)
804 ((arg & 256) ?
805 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
a1b95068 806#else
10edeb5d
JH		 807 fmt = (const char *)
808 ((arg & 256) ?
809 "%#0*.*f" : "%0*.*f");
a1b95068
WL		 810#endif
811 goto ff_dec;
a0d0e21e 812 case FF_DECIMAL:
a0d0e21e 813 arg = *fpc++;
65202027 814#if defined(USE_LONG_DOUBLE)
10edeb5d
JH		 815 fmt = (const char *)
816 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
65202027 817#else
10edeb5d
JH		 818 fmt = (const char *)
819 ((arg & 256) ? "%#*.*f" : "%*.*f");
65202027 820#endif
a1b95068 821 ff_dec:
784707d5
JP		 822 /* If the field is marked with ^ and the value is undefined,
823 blank it out. */
784707d5
JP		 824 if ((arg & 512) && !SvOK(sv)) {
825 arg = fieldsize;
826 while (arg--)
827 *t++ = ' ';
828 break;
829 }
830 gotsome = TRUE;
831 value = SvNV(sv);
a1b95068 832 /* overflow evidence */
bfed75c6 833 if (num_overflow(value, fieldsize, arg)) {
a1b95068
WL		 834 arg = fieldsize;
835 while (arg--)
836 *t++ = '#';
837 break;
838 }
784707d5
JP		 839 /* Formats aren't yet marked for locales, so assume "yes". */
840 {
841 STORE_NUMERIC_STANDARD_SET_LOCAL();
d9fad198 842 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
784707d5
JP		 843 RESTORE_NUMERIC_STANDARD();
844 }
845 t += fieldsize;
846 break;
a1b95068 847
a0d0e21e
LW		 848 case FF_NEWLINE:
849 f++;
850 while (t-- > linemark && *t == ' ') ;
851 t++;
852 *t++ = '\n';
853 break;
854
855 case FF_BLANK:
856 arg = *fpc++;
857 if (gotsome) {
858 if (arg) { /* repeat until fields exhausted? */
859 *t = '\0';
b15aece3 860 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
3280af22 861 lines += FmLINES(PL_formtarget);
a0d0e21e
LW		 862 if (lines == 200) {
863 arg = t - linemark;
864 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 865 DIE(aTHX_ "Runaway format");
a0d0e21e 866 }
1bd51a4c
IH		 867 if (targ_is_utf8)
868 SvUTF8_on(PL_formtarget);
3280af22 869 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW		 870 SP = ORIGMARK;
871 RETURNOP(cLISTOP->op_first);
872 }
873 }
874 else {
875 t = linemark;
876 lines--;
877 }
878 break;
879
880 case FF_MORE:
5a34cab7
NC		 881 {
882 const char *s = chophere;
883 const char *send = item + len;
884 if (chopspace) {
af68e756 885 while (isSPACE(*s) && (s < send))
5a34cab7 886 s++;
a0d0e21e 887 }
5a34cab7
NC		 888 if (s < send) {
889 char *s1;
890 arg = fieldsize - itemsize;
891 if (arg) {
892 fieldsize -= arg;
893 while (arg-- > 0)
894 *t++ = ' ';
895 }
896 s1 = t - 3;
897 if (strnEQ(s1," ",3)) {
898 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
899 s1--;
900 }
901 *s1++ = '.';
902 *s1++ = '.';
903 *s1++ = '.';
a0d0e21e 904 }
5a34cab7 905 break;
a0d0e21e 906 }
a0d0e21e
LW		 907 case FF_END:
908 *t = '\0';
b15aece3 909 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 910 if (targ_is_utf8)
911 SvUTF8_on(PL_formtarget);
3280af22 912 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW		 913 SP = ORIGMARK;
914 RETPUSHYES;
915 }
916 }
917}
918
919PP(pp_grepstart)
920{
27da23d5 921 dVAR; dSP;
a0d0e21e
LW		 922 SV *src;
923
3280af22 924 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 925 (void)POPMARK;
54310121 926 if (GIMME_V == G_SCALAR)
0b024f31 927 XPUSHs(sv_2mortal(newSViv(0)));
533c011a 928 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 929 }
3280af22 930 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS		 931 pp_pushmark(); /* push dst */
932 pp_pushmark(); /* push src */
a0d0e21e
LW		 933 ENTER; /* enter outer scope */
934
935 SAVETMPS;
59f00321
RGS		 936 if (PL_op->op_private & OPpGREP_LEX)
937 SAVESPTR(PAD_SVl(PL_op->op_targ));
938 else
939 SAVE_DEFSV;
a0d0e21e 940 ENTER; /* enter inner scope */
7766f137 941 SAVEVPTR(PL_curpm);
a0d0e21e 942
3280af22 943 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 944 SvTEMP_off(src);
59f00321
RGS		 945 if (PL_op->op_private & OPpGREP_LEX)
946 PAD_SVl(PL_op->op_targ) = src;
947 else
948 DEFSV = src;
a0d0e21e
LW		 949
950 PUTBACK;
533c011a 951 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 952 pp_pushmark(); /* push top */
533c011a 953 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 954}
955
a0d0e21e
LW		 956PP(pp_mapwhile)
957{
27da23d5 958 dVAR; dSP;
f54cb97a 959 const I32 gimme = GIMME_V;
544f3153 960 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW		 961 I32 count;
962 I32 shift;
963 SV** src;
ac27b0f5 964 SV** dst;
a0d0e21e 965
544f3153 966 /* first, move source pointer to the next item in the source list */
3280af22 967 ++PL_markstack_ptr[-1];
544f3153
GS		 968
969 /* if there are new items, push them into the destination list */
4c90a460 970 if (items && gimme != G_VOID) {
544f3153
GS		 971 /* might need to make room back there first */
972 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
973 /* XXX this implementation is very pessimal because the stack
974 * is repeatedly extended for every set of items. Is possible
975 * to do this without any stack extension or copying at all
976 * by maintaining a separate list over which the map iterates
18ef8bea 977 * (like foreach does). --gsar */
544f3153
GS		 978
979 /* everything in the stack after the destination list moves
980 * towards the end the stack by the amount of room needed */
981 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
982
983 /* items to shift up (accounting for the moved source pointer) */
984 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT		 985
986 /* This optimization is by Ben Tilly and it does
987 * things differently from what Sarathy (gsar)
988 * is describing. The downside of this optimization is
989 * that leaves "holes" (uninitialized and hopefully unused areas)
990 * to the Perl stack, but on the other hand this
991 * shouldn't be a problem. If Sarathy's idea gets
992 * implemented, this optimization should become
993 * irrelevant. --jhi */
994 if (shift < count)
995 shift = count; /* Avoid shifting too often --Ben Tilly */
bfed75c6 996
924508f0
GS		 997 EXTEND(SP,shift);
998 src = SP;
999 dst = (SP += shift);
3280af22
NIS		 1000 PL_markstack_ptr[-1] += shift;
1001 *PL_markstack_ptr += shift;
544f3153 1002 while (count--)
a0d0e21e
LW		 1003 *dst-- = *src--;
1004 }
544f3153 1005 /* copy the new items down to the destination list */
ac27b0f5 1006 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26
TP		 1007 if (gimme == G_ARRAY) {
1008 while (items-- > 0)
1009 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1010 }
bfed75c6 1011 else {
22023b26
TP		 1012 /* scalar context: we don't care about which values map returns
1013 * (we use undef here). And so we certainly don't want to do mortal
1014 * copies of meaningless values. */
1015 while (items-- > 0) {
b988aa42 1016 (void)POPs;
22023b26
TP		 1017 *dst-- = &PL_sv_undef;
1018 }
1019 }
a0d0e21e
LW		 1020 }
1021 LEAVE; /* exit inner scope */
1022
1023 /* All done yet? */
3280af22 1024 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW		 1025
1026 (void)POPMARK; /* pop top */
1027 LEAVE; /* exit outer scope */
1028 (void)POPMARK; /* pop src */
3280af22 1029 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1030 (void)POPMARK; /* pop dst */
3280af22 1031 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1032 if (gimme == G_SCALAR) {
7cc47870
RGS		 1033 if (PL_op->op_private & OPpGREP_LEX) {
1034 SV* sv = sv_newmortal();
1035 sv_setiv(sv, items);
1036 PUSHs(sv);
1037 }
1038 else {
1039 dTARGET;
1040 XPUSHi(items);
1041 }
a0d0e21e 1042 }
54310121 1043 else if (gimme == G_ARRAY)
1044 SP += items;
a0d0e21e
LW		 1045 RETURN;
1046 }
1047 else {
1048 SV *src;
1049
1050 ENTER; /* enter inner scope */
7766f137 1051 SAVEVPTR(PL_curpm);
a0d0e21e 1052
544f3153 1053 /* set $_ to the new source item */
3280af22 1054 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1055 SvTEMP_off(src);
59f00321
RGS		 1056 if (PL_op->op_private & OPpGREP_LEX)
1057 PAD_SVl(PL_op->op_targ) = src;
1058 else
1059 DEFSV = src;
a0d0e21e
LW		 1060
1061 RETURNOP(cLOGOP->op_other);
1062 }
1063}
1064
a0d0e21e
LW		 1065/* Range stuff. */
1066
1067PP(pp_range)
1068{
97aff369 1069 dVAR;
a0d0e21e 1070 if (GIMME == G_ARRAY)
1a67a97c 1071 return NORMAL;
538573f7 1072 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1073 return cLOGOP->op_other;
538573f7 1074 else
1a67a97c 1075 return NORMAL;
a0d0e21e
LW		 1076}
1077
1078PP(pp_flip)
1079{
97aff369 1080 dVAR;
39644a26 1081 dSP;
a0d0e21e
LW		 1082
1083 if (GIMME == G_ARRAY) {
1a67a97c 1084 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1085 }
1086 else {
1087 dTOPss;
44f8325f 1088 SV * const targ = PAD_SV(PL_op->op_targ);
bfed75c6 1089 int flip = 0;
790090df 1090
bfed75c6 1091 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST		 1092 if (GvIO(PL_last_in_gv)) {
1093 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1094 }
1095 else {
fafc274c 1096 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
44f8325f
AL		 1097 if (gv && GvSV(gv))
1098 flip = SvIV(sv) == SvIV(GvSV(gv));
4e3399f9 1099 }
bfed75c6
AL		 1100 } else {
1101 flip = SvTRUE(sv);
1102 }
1103 if (flip) {
a0d0e21e 1104 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1105 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1106 sv_setiv(targ, 1);
3e3baf6d 1107 SETs(targ);
a0d0e21e
LW		 1108 RETURN;
1109 }
1110 else {
1111 sv_setiv(targ, 0);
924508f0 1112 SP--;
1a67a97c 1113 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1114 }
1115 }
c69006e4 1116 sv_setpvn(TARG, "", 0);
a0d0e21e
LW		 1117 SETs(targ);
1118 RETURN;
1119 }
1120}
1121
8e9bbdb9
RGS		 1122/* This code tries to decide if "$left .. $right" should use the
1123 magical string increment, or if the range is numeric (we make
1124 an exception for .."0" [#18165]). AMS 20021031. */
1125
1126#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS		 1127 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1128 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e 1129 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
b15aece3 1130 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
e0ab1c0e 1131 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1132
a0d0e21e
LW		 1133PP(pp_flop)
1134{
97aff369 1135 dVAR; dSP;
a0d0e21e
LW		 1136
1137 if (GIMME == G_ARRAY) {
1138 dPOPPOPssrl;
86cb7173 1139
5b295bef
RD		 1140 SvGETMAGIC(left);
1141 SvGETMAGIC(right);
a0d0e21e 1142
8e9bbdb9 1143 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL		 1144 register IV i, j;
1145 IV max;
4fe3f0fa
MHM		 1146 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1147 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1148 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1149 i = SvIV(left);
1150 max = SvIV(right);
bbce6d69 1151 if (max >= i) {
c1ab3db2
AK		 1152 j = max - i + 1;
1153 EXTEND_MORTAL(j);
1154 EXTEND(SP, j);
bbce6d69 1155 }
c1ab3db2
AK		 1156 else
1157 j = 0;
1158 while (j--) {
901017d6 1159 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1160 PUSHs(sv);
1161 }
1162 }
1163 else {
44f8325f 1164 SV * const final = sv_mortalcopy(right);
13c5b33c 1165 STRLEN len;
823a54a3 1166 const char * const tmps = SvPV_const(final, len);
a0d0e21e 1167
901017d6 1168 SV *sv = sv_mortalcopy(left);
13c5b33c 1169 SvPV_force_nolen(sv);
89ea2908 1170 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1171 XPUSHs(sv);
b15aece3 1172 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1173 break;
a0d0e21e
LW		 1174 sv = sv_2mortal(newSVsv(sv));
1175 sv_inc(sv);
1176 }
a0d0e21e
LW		 1177 }
1178 }
1179 else {
1180 dTOPss;
901017d6 1181 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1182 int flop = 0;
a0d0e21e 1183 sv_inc(targ);
4e3399f9
YST		 1184
1185 if (PL_op->op_private & OPpFLIP_LINENUM) {
1186 if (GvIO(PL_last_in_gv)) {
1187 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1188 }
1189 else {
fafc274c 1190 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
4e3399f9
YST		 1191 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1192 }
1193 }
1194 else {
1195 flop = SvTRUE(sv);
1196 }
1197
1198 if (flop) {
a0d0e21e 1199 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
396482e1 1200 sv_catpvs(targ, "E0");
a0d0e21e
LW		 1201 }
1202 SETs(targ);
1203 }
1204
1205 RETURN;
1206}
1207
1208/* Control. */
1209
27da23d5 1210static const char * const context_name[] = {
515afda2
NC		 1211 "pseudo-block",
1212 "subroutine",
1213 "eval",
1214 "loop",
1215 "substitution",
1216 "block",
0d863452
RH		 1217 "format",
1218 "given",
1219 "when"
515afda2
NC		 1220};
1221
76e3520e 1222STATIC I32
06b5626a 1223S_dopoptolabel(pTHX_ const char *label)
a0d0e21e 1224{
97aff369 1225 dVAR;
a0d0e21e 1226 register I32 i;
a0d0e21e
LW		 1227
1228 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1229 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1230 switch (CxTYPE(cx)) {
a0d0e21e 1231 case CXt_SUBST:
a0d0e21e 1232 case CXt_SUB:
7766f137 1233 case CXt_FORMAT:
a0d0e21e 1234 case CXt_EVAL:
0a753a76 1235 case CXt_NULL:
0d863452
RH		 1236 case CXt_GIVEN:
1237 case CXt_WHEN:
e476b1b5 1238 if (ckWARN(WARN_EXITING))
515afda2
NC		 1239 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1240 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1241 if (CxTYPE(cx) == CXt_NULL)
1242 return -1;
1243 break;
a0d0e21e 1244 case CXt_LOOP:
901017d6 1245 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1246 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1247 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1248 continue;
1249 }
cea2e8a9 1250 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1251 return i;
1252 }
1253 }
1254 return i;
1255}
1256
0d863452
RH		 1257
1258
e50aee73 1259I32
864dbfa3 1260Perl_dowantarray(pTHX)
e50aee73 1261{
97aff369 1262 dVAR;
f54cb97a 1263 const I32 gimme = block_gimme();
54310121 1264 return (gimme == G_VOID) ? G_SCALAR : gimme;
1265}
1266
1267I32
864dbfa3 1268Perl_block_gimme(pTHX)
54310121 1269{
97aff369 1270 dVAR;
06b5626a 1271 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1272 if (cxix < 0)
46fc3d4c 1273 return G_VOID;
e50aee73 1274
54310121 1275 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1276 case G_VOID:
1277 return G_VOID;
54310121 1278 case G_SCALAR:
e50aee73 1279 return G_SCALAR;
54310121 1280 case G_ARRAY:
1281 return G_ARRAY;
1282 default:
cea2e8a9 1283 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1284 /* NOTREACHED */
1285 return 0;
54310121 1286 }
e50aee73
AD		 1287}
1288
78f9721b
SM		 1289I32
1290Perl_is_lvalue_sub(pTHX)
1291{
97aff369 1292 dVAR;
06b5626a 1293 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM		 1294 assert(cxix >= 0); /* We should only be called from inside subs */
1295
cc8d50a7
NC		 1296 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1297 return cxstack[cxix].blk_sub.lval;
78f9721b
SM		 1298 else
1299 return 0;
1300}
1301
76e3520e 1302STATIC I32
cea2e8a9 1303S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1304{
97aff369 1305 dVAR;
2c375eb9
GS		 1306 return dopoptosub_at(cxstack, startingblock);
1307}
1308
1309STATIC I32
901017d6 1310S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1311{
97aff369 1312 dVAR;
a0d0e21e 1313 I32 i;
a0d0e21e 1314 for (i = startingblock; i >= 0; i--) {
901017d6 1315 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1316 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1317 default:
1318 continue;
1319 case CXt_EVAL:
1320 case CXt_SUB:
7766f137 1321 case CXt_FORMAT:
cea2e8a9 1322 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1323 return i;
1324 }
1325 }
1326 return i;
1327}
1328
76e3520e 1329STATIC I32
cea2e8a9 1330S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1331{
97aff369 1332 dVAR;
a0d0e21e 1333 I32 i;
a0d0e21e 1334 for (i = startingblock; i >= 0; i--) {
06b5626a 1335 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1336 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1337 default:
1338 continue;
1339 case CXt_EVAL:
cea2e8a9 1340 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1341 return i;
1342 }
1343 }
1344 return i;
1345}
1346
76e3520e 1347STATIC I32
cea2e8a9 1348S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1349{
97aff369 1350 dVAR;
a0d0e21e 1351 I32 i;
a0d0e21e 1352 for (i = startingblock; i >= 0; i--) {
901017d6 1353 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1354 switch (CxTYPE(cx)) {
a0d0e21e 1355 case CXt_SUBST:
a0d0e21e 1356 case CXt_SUB:
7766f137 1357 case CXt_FORMAT:
a0d0e21e 1358 case CXt_EVAL:
0a753a76 1359 case CXt_NULL:
e476b1b5 1360 if (ckWARN(WARN_EXITING))
515afda2
NC		 1361 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1362 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1363 if ((CxTYPE(cx)) == CXt_NULL)
1364 return -1;
1365 break;
a0d0e21e 1366 case CXt_LOOP:
cea2e8a9 1367 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1368 return i;
1369 }
1370 }
1371 return i;
1372}
1373
0d863452
RH		 1374STATIC I32
1375S_dopoptogiven(pTHX_ I32 startingblock)
1376{
97aff369 1377 dVAR;
0d863452
RH		 1378 I32 i;
1379 for (i = startingblock; i >= 0; i--) {
1380 register const PERL_CONTEXT *cx = &cxstack[i];
1381 switch (CxTYPE(cx)) {
1382 default:
1383 continue;
1384 case CXt_GIVEN:
1385 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1386 return i;
1387 case CXt_LOOP:
1388 if (CxFOREACHDEF(cx)) {
1389 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1390 return i;
1391 }
1392 }
1393 }
1394 return i;
1395}
1396
1397STATIC I32
1398S_dopoptowhen(pTHX_ I32 startingblock)
1399{
97aff369 1400 dVAR;
0d863452
RH		 1401 I32 i;
1402 for (i = startingblock; i >= 0; i--) {
1403 register const PERL_CONTEXT *cx = &cxstack[i];
1404 switch (CxTYPE(cx)) {
1405 default:
1406 continue;
1407 case CXt_WHEN:
1408 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1409 return i;
1410 }
1411 }
1412 return i;
1413}
1414
a0d0e21e 1415void
864dbfa3 1416Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1417{
97aff369 1418 dVAR;
a0d0e21e
LW		 1419 I32 optype;
1420
1421 while (cxstack_ix > cxix) {
b0d9ce38 1422 SV *sv;
06b5626a 1423 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1424 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1425 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1426 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1427 switch (CxTYPE(cx)) {
c90c0ff4 1428 case CXt_SUBST:
1429 POPSUBST(cx);
1430 continue; /* not break */
a0d0e21e 1431 case CXt_SUB:
b0d9ce38
GS		 1432 POPSUB(cx,sv);
1433 LEAVESUB(sv);
a0d0e21e
LW		 1434 break;
1435 case CXt_EVAL:
1436 POPEVAL(cx);
1437 break;
1438 case CXt_LOOP:
1439 POPLOOP(cx);
1440 break;
0a753a76 1441 case CXt_NULL:
a0d0e21e 1442 break;
7766f137
GS		 1443 case CXt_FORMAT:
1444 POPFORMAT(cx);
1445 break;
a0d0e21e 1446 }
c90c0ff4 1447 cxstack_ix--;
a0d0e21e 1448 }
1b6737cc 1449 PERL_UNUSED_VAR(optype);
a0d0e21e
LW		 1450}
1451
5a844595
GS		 1452void
1453Perl_qerror(pTHX_ SV *err)
1454{
97aff369 1455 dVAR;
5a844595
GS		 1456 if (PL_in_eval)
1457 sv_catsv(ERRSV, err);
1458 else if (PL_errors)
1459 sv_catsv(PL_errors, err);
1460 else
be2597df 1461 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
13765c85
DM		 1462 if (PL_parser)
1463 ++PL_parser->error_count;
5a844595
GS		 1464}
1465
a0d0e21e 1466OP *
35a4481c 1467Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1468{
27da23d5 1469 dVAR;
87582a92 1470
3280af22 1471 if (PL_in_eval) {
a0d0e21e 1472 I32 cxix;
a0d0e21e 1473 I32 gimme;
a0d0e21e 1474
4e6ea2c3 1475 if (message) {
faef0170 1476 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1477 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1478 SV * const err = ERRSV;
c445ea15 1479 const char *e = NULL;
98eae8f5 1480 if (!SvPOK(err))
c69006e4 1481 sv_setpvn(err,"",0);
98eae8f5 1482 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1483 STRLEN len;
349d4f2f 1484 e = SvPV_const(err, len);
0510663f 1485 e += len - msglen;
98eae8f5 1486 if (*e != *message || strNE(e,message))
c445ea15 1487 e = NULL;
98eae8f5
GS		 1488 }
1489 if (!e) {
1490 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1491 sv_catpvn(err, prefix, sizeof(prefix)-1);
1492 sv_catpvn(err, message, msglen);
e476b1b5 1493 if (ckWARN(WARN_MISC)) {
504618e9 1494 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1495 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1496 }
4633a7c4 1497 }
4633a7c4 1498 }
1aa99e6b 1499 else {
06bf62c7 1500 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1501 }
4633a7c4 1502 }
4e6ea2c3 1503
5a844595
GS		 1504 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1505 && PL_curstackinfo->si_prev)
1506 {
bac4b2ad 1507 dounwind(-1);
d3acc0f7 1508 POPSTACK;
bac4b2ad 1509 }
e336de0d 1510
a0d0e21e
LW		 1511 if (cxix >= 0) {
1512 I32 optype;
35a4481c 1513 register PERL_CONTEXT *cx;
901017d6 1514 SV **newsp;
a0d0e21e
LW		 1515
1516 if (cxix < cxstack_ix)
1517 dounwind(cxix);
1518
3280af22 1519 POPBLOCK(cx,PL_curpm);
6b35e009 1520 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1521 if (!message)
349d4f2f 1522 message = SvPVx_const(ERRSV, msglen);
10edeb5d 1523 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
bf49b057 1524 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1525 my_exit(1);
1526 }
1527 POPEVAL(cx);
1528
1529 if (gimme == G_SCALAR)
3280af22
NIS		 1530 *++newsp = &PL_sv_undef;
1531 PL_stack_sp = newsp;
a0d0e21e
LW		 1532
1533 LEAVE;
748a9306 1534
7fb6a879
GS		 1535 /* LEAVE could clobber PL_curcop (see save_re_context())
1536 * XXX it might be better to find a way to avoid messing with
1537 * PL_curcop in save_re_context() instead, but this is a more
1538 * minimal fix --GSAR */
1539 PL_curcop = cx->blk_oldcop;
1540
7a2e2cd6 1541 if (optype == OP_REQUIRE) {
44f8325f 1542 const char* const msg = SvPVx_nolen_const(ERRSV);
901017d6 1543 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1544 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1545 &PL_sv_undef, 0);
5a844595
GS		 1546 DIE(aTHX_ "%sCompilation failed in require",
1547 *msg ? msg : "Unknown error\n");
7a2e2cd6 1548 }
f39bc417
DM		 1549 assert(CxTYPE(cx) == CXt_EVAL);
1550 return cx->blk_eval.retop;
a0d0e21e
LW		 1551 }
1552 }
9cc2fdd3 1553 if (!message)
349d4f2f 1554 message = SvPVx_const(ERRSV, msglen);
87582a92 1555
7ff03255 1556 write_to_stderr(message, msglen);
f86702cc 1557 my_failure_exit();
1558 /* NOTREACHED */
a0d0e21e
LW		 1559 return 0;
1560}
1561
1562PP(pp_xor)
1563{
97aff369 1564 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW		 1565 if (SvTRUE(left) != SvTRUE(right))
1566 RETSETYES;
1567 else
1568 RETSETNO;
1569}
1570
a0d0e21e
LW		 1571PP(pp_caller)
1572{
97aff369 1573 dVAR;
39644a26 1574 dSP;
a0d0e21e 1575 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1576 register const PERL_CONTEXT *cx;
1577 register const PERL_CONTEXT *ccstack = cxstack;
1578 const PERL_SI *top_si = PL_curstackinfo;
54310121 1579 I32 gimme;
06b5626a 1580 const char *stashname;
a0d0e21e
LW		 1581 I32 count = 0;
1582
1583 if (MAXARG)
1584 count = POPi;
27d41816 1585
a0d0e21e 1586 for (;;) {
2c375eb9
GS		 1587 /* we may be in a higher stacklevel, so dig down deeper */
1588 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1589 top_si = top_si->si_prev;
1590 ccstack = top_si->si_cxstack;
1591 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1592 }
a0d0e21e 1593 if (cxix < 0) {
27d41816
DM		 1594 if (GIMME != G_ARRAY) {
1595 EXTEND(SP, 1);
a0d0e21e 1596 RETPUSHUNDEF;
27d41816 1597 }
a0d0e21e
LW		 1598 RETURN;
1599 }
f2a7f298
DG		 1600 /* caller() should not report the automatic calls to &DB::sub */
1601 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1602 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1603 count++;
1604 if (!count--)
1605 break;
2c375eb9 1606 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1607 }
2c375eb9
GS		 1608
1609 cx = &ccstack[cxix];
7766f137 1610 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1611 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1612 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1613 field below is defined for any cx. */
f2a7f298
DG		 1614 /* caller() should not report the automatic calls to &DB::sub */
1615 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1616 cx = &ccstack[dbcxix];
06a5b730 1617 }
1618
ed094faf 1619 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1620 if (GIMME != G_ARRAY) {
27d41816 1621 EXTEND(SP, 1);
ed094faf 1622 if (!stashname)
3280af22 1623 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1624 else {
1625 dTARGET;
ed094faf 1626 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1627 PUSHs(TARG);
1628 }
a0d0e21e
LW		 1629 RETURN;
1630 }
a0d0e21e 1631
b3ca2e83 1632 EXTEND(SP, 11);
27d41816 1633
ed094faf 1634 if (!stashname)
3280af22 1635 PUSHs(&PL_sv_undef);
49d8d3a1 1636 else
ed094faf 1637 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1638 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1639 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1640 if (!MAXARG)
1641 RETURN;
7766f137 1642 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1643 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1644 /* So is ccstack[dbcxix]. */
07b8c804 1645 if (isGV(cvgv)) {
561b68a9 1646 SV * const sv = newSV(0);
c445ea15 1647 gv_efullname3(sv, cvgv, NULL);
07b8c804 1648 PUSHs(sv_2mortal(sv));
cc8d50a7 1649 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804
RGS		 1650 }
1651 else {
396482e1 1652 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
cc8d50a7 1653 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1654 }
a0d0e21e
LW		 1655 }
1656 else {
396482e1 1657 PUSHs(sv_2mortal(newSVpvs("(eval)")));
a0d0e21e
LW		 1658 PUSHs(sv_2mortal(newSViv(0)));
1659 }
54310121 1660 gimme = (I32)cx->blk_gimme;
1661 if (gimme == G_VOID)
3280af22 1662 PUSHs(&PL_sv_undef);
54310121 1663 else
1664 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1665 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1666 /* eval STRING */
06a5b730 1667 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1668 PUSHs(cx->blk_eval.cur_text);
3280af22 1669 PUSHs(&PL_sv_no);
0f79a09d 1670 }
811a4de9 1671 /* require */
0f79a09d
GS		 1672 else if (cx->blk_eval.old_namesv) {
1673 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1674 PUSHs(&PL_sv_yes);
06a5b730 1675 }
811a4de9
GS		 1676 /* eval BLOCK (try blocks have old_namesv == 0) */
1677 else {
1678 PUSHs(&PL_sv_undef);
1679 PUSHs(&PL_sv_undef);
1680 }
4633a7c4 1681 }
a682de96
GS		 1682 else {
1683 PUSHs(&PL_sv_undef);
1684 PUSHs(&PL_sv_undef);
1685 }
cc8d50a7 1686 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1687 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1688 {
66a1b24b
AL		 1689 AV * const ary = cx->blk_sub.argarray;
1690 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1691
3280af22 1692 if (!PL_dbargs) {
71315bf2 1693 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
0bd48802 1694 PL_dbargs = GvAV(gv_AVadd(tmpgv));
a5f75d66 1695 GvMULTI_on(tmpgv);
3ddcf04c 1696 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW		 1697 }
1698
3280af22
NIS		 1699 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1700 av_extend(PL_dbargs, AvFILLp(ary) + off);
1701 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1702 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1703 }
f3aa04c2
GS		 1704 /* XXX only hints propagated via op_private are currently
1705 * visible (others are not easily accessible, since they
1706 * use the global PL_hints) */
623e6609 1707 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
e476b1b5
GS		 1708 {
1709 SV * mask ;
72dc9ed5 1710 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1711
ac27b0f5 1712 if (old_warnings == pWARN_NONE ||
114bafba 1713 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1714 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1715 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1716 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1717 /* Get the bit mask for $warnings::Bits{all}, because
1718 * it could have been extended by warnings::register */
1719 SV **bits_all;
0bd48802 1720 HV * const bits = get_hv("warnings::Bits", FALSE);
017a3ce5 1721 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS		 1722 mask = newSVsv(*bits_all);
1723 }
1724 else {
1725 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1726 }
1727 }
e476b1b5 1728 else
72dc9ed5 1729 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
e476b1b5
GS		 1730 PUSHs(sv_2mortal(mask));
1731 }
b3ca2e83 1732
c28fe1ec 1733 PUSHs(cx->blk_oldcop->cop_hints_hash ?
b3ca2e83 1734 sv_2mortal(newRV_noinc(
c28fe1ec
NC		 1735 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1736 cx->blk_oldcop->cop_hints_hash)))
b3ca2e83 1737 : &PL_sv_undef);
a0d0e21e
LW		 1738 RETURN;
1739}
1740
a0d0e21e
LW		 1741PP(pp_reset)
1742{
97aff369 1743 dVAR;
39644a26 1744 dSP;
10edeb5d 1745 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
11faa288 1746 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1747 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1748 RETURN;
1749}
1750
dd2155a4
DM		 1751/* like pp_nextstate, but used instead when the debugger is active */
1752
a0d0e21e
LW		 1753PP(pp_dbstate)
1754{
27da23d5 1755 dVAR;
533c011a 1756 PL_curcop = (COP*)PL_op;
a0d0e21e 1757 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1758 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1759 FREETMPS;
1760
5df8de69
DM		 1761 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1762 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1763 {
39644a26 1764 dSP;
c09156bb 1765 register PERL_CONTEXT *cx;
f54cb97a 1766 const I32 gimme = G_ARRAY;
eb160463 1767 U8 hasargs;
0bd48802
AL		 1768 GV * const gv = PL_DBgv;
1769 register CV * const cv = GvCV(gv);
a0d0e21e 1770
a0d0e21e 1771 if (!cv)
cea2e8a9 1772 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1773
aea4f609
DM		 1774 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1775 /* don't do recursive DB::DB call */
a0d0e21e 1776 return NORMAL;
748a9306 1777
4633a7c4
LW		 1778 ENTER;
1779 SAVETMPS;
1780
3280af22 1781 SAVEI32(PL_debug);
55497cff 1782 SAVESTACK_POS();
3280af22 1783 PL_debug = 0;
748a9306 1784 hasargs = 0;
924508f0 1785 SPAGAIN;
748a9306 1786
aed2304a 1787 if (CvISXSUB(cv)) {
c127bd3a
SF		 1788 CvDEPTH(cv)++;
1789 PUSHMARK(SP);
1790 (void)(*CvXSUB(cv))(aTHX_ cv);
1791 CvDEPTH(cv)--;
1792 FREETMPS;
1793 LEAVE;
1794 return NORMAL;
1795 }
1796 else {
1797 PUSHBLOCK(cx, CXt_SUB, SP);
1798 PUSHSUB_DB(cx);
1799 cx->blk_sub.retop = PL_op->op_next;
1800 CvDEPTH(cv)++;
1801 SAVECOMPPAD();
1802 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1803 RETURNOP(CvSTART(cv));
1804 }
a0d0e21e
LW		 1805 }
1806 else
1807 return NORMAL;
1808}
1809
a0d0e21e
LW		 1810PP(pp_enteriter)
1811{
27da23d5 1812 dVAR; dSP; dMARK;
c09156bb 1813 register PERL_CONTEXT *cx;
f54cb97a 1814 const I32 gimme = GIMME_V;
a0d0e21e 1815 SV **svp;
df43650b 1816 U16 cxtype = CXt_LOOP | CXp_FOREACH;
7766f137
GS		 1817#ifdef USE_ITHREADS
1818 void *iterdata;
1819#endif
a0d0e21e 1820
4633a7c4
LW		 1821 ENTER;
1822 SAVETMPS;
1823
533c011a 1824 if (PL_op->op_targ) {
14f338dc
DM		 1825 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1826 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1827 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1828 SVs_PADSTALE, SVs_PADSTALE);
1829 }
c3564e5c 1830#ifndef USE_ITHREADS
dd2155a4 1831 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1832 SAVESPTR(*svp);
c3564e5c
GS		 1833#else
1834 SAVEPADSV(PL_op->op_targ);
cbfa9890 1835 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1836 cxtype |= CXp_PADVAR;
1837#endif
54b9620d
MB		 1838 }
1839 else {
0bd48802 1840 GV * const gv = (GV*)POPs;
7766f137 1841 svp = &GvSV(gv); /* symbol table variable */
0214ae40 1842 SAVEGENERICSV(*svp);
561b68a9 1843 *svp = newSV(0);
7766f137
GS		 1844#ifdef USE_ITHREADS
1845 iterdata = (void*)gv;
1846#endif
54b9620d 1847 }
4633a7c4 1848
0d863452
RH		 1849 if (PL_op->op_private & OPpITER_DEF)
1850 cxtype |= CXp_FOR_DEF;
1851
a0d0e21e
LW		 1852 ENTER;
1853
7766f137
GS		 1854 PUSHBLOCK(cx, cxtype, SP);
1855#ifdef USE_ITHREADS
1856 PUSHLOOP(cx, iterdata, MARK);
1857#else
a0d0e21e 1858 PUSHLOOP(cx, svp, MARK);
7766f137 1859#endif
533c011a 1860 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1861 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1862 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1863 dPOPss;
0bd48802 1864 SV * const right = (SV*)cx->blk_loop.iterary;
984a4bea
RD		 1865 SvGETMAGIC(sv);
1866 SvGETMAGIC(right);
4fe3f0fa
MHM		 1867 if (RANGE_IS_NUMERIC(sv,right)) {
1868 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1869 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1870 DIE(aTHX_ "Range iterator outside integer range");
1871 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1872 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM		 1873#ifdef DEBUGGING
1874 /* for correct -Dstv display */
1875 cx->blk_oldsp = sp - PL_stack_base;
1876#endif
89ea2908 1877 }
3f63a782 1878 else {
89ea2908 1879 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1880 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1881 (void) SvPV_nolen_const(right);
3f63a782 1882 }
89ea2908 1883 }
ef3e5ea9 1884 else if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1885 cx->blk_loop.itermax = 0;
1886 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
ef3e5ea9
NC		 1887
1888 }
89ea2908 1889 }
4633a7c4 1890 else {
3280af22
NIS		 1891 cx->blk_loop.iterary = PL_curstack;
1892 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9 1893 if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1894 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1895 cx->blk_loop.iterix = cx->blk_oldsp + 1;
ef3e5ea9
NC		 1896 }
1897 else {
1898 cx->blk_loop.iterix = MARK - PL_stack_base;
1899 }
4633a7c4 1900 }
a0d0e21e
LW		 1901
1902 RETURN;
1903}
1904
1905PP(pp_enterloop)
1906{
27da23d5 1907 dVAR; dSP;
c09156bb 1908 register PERL_CONTEXT *cx;
f54cb97a 1909 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1910
1911 ENTER;
1912 SAVETMPS;
1913 ENTER;
1914
1915 PUSHBLOCK(cx, CXt_LOOP, SP);
1916 PUSHLOOP(cx, 0, SP);
1917
1918 RETURN;
1919}
1920
1921PP(pp_leaveloop)
1922{
27da23d5 1923 dVAR; dSP;
c09156bb 1924 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1925 I32 gimme;
1926 SV **newsp;
1927 PMOP *newpm;
1928 SV **mark;
1929
1930 POPBLOCK(cx,newpm);
3a1b2b9e 1931 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1932 mark = newsp;
a8bba7fa 1933 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1934
a1f49e72 1935 TAINT_NOT;
54310121 1936 if (gimme == G_VOID)
6f207bd3 1937 NOOP;
54310121 1938 else if (gimme == G_SCALAR) {
1939 if (mark < SP)
1940 *++newsp = sv_mortalcopy(*SP);
1941 else
3280af22 1942 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1943 }
1944 else {
a1f49e72 1945 while (mark < SP) {
a0d0e21e 1946 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1947 TAINT_NOT; /* Each item is independent */
1948 }
a0d0e21e 1949 }
f86702cc 1950 SP = newsp;
1951 PUTBACK;
1952
a8bba7fa 1953 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1954 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1955
a0d0e21e
LW		 1956 LEAVE;
1957 LEAVE;
1958
f86702cc 1959 return NORMAL;
a0d0e21e
LW		 1960}
1961
1962PP(pp_return)
1963{
27da23d5 1964 dVAR; dSP; dMARK;
c09156bb 1965 register PERL_CONTEXT *cx;
f86702cc 1966 bool popsub2 = FALSE;
b45de488 1967 bool clear_errsv = FALSE;
a0d0e21e
LW		 1968 I32 gimme;
1969 SV **newsp;
1970 PMOP *newpm;
1971 I32 optype = 0;
b0d9ce38 1972 SV *sv;
f39bc417 1973 OP *retop;
a0d0e21e 1974
0bd48802
AL		 1975 const I32 cxix = dopoptosub(cxstack_ix);
1976
9850bf21
RH		 1977 if (cxix < 0) {
1978 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1979 * sort block, which is a CXt_NULL
1980 * not a CXt_SUB */
1981 dounwind(0);
d7507f74
RH		 1982 PL_stack_base[1] = *PL_stack_sp;
1983 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1984 return 0;
1985 }
9850bf21
RH		 1986 else
1987 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 1988 }
a0d0e21e
LW		 1989 if (cxix < cxstack_ix)
1990 dounwind(cxix);
1991
d7507f74
RH		 1992 if (CxMULTICALL(&cxstack[cxix])) {
1993 gimme = cxstack[cxix].blk_gimme;
1994 if (gimme == G_VOID)
1995 PL_stack_sp = PL_stack_base;
1996 else if (gimme == G_SCALAR) {
1997 PL_stack_base[1] = *PL_stack_sp;
1998 PL_stack_sp = PL_stack_base + 1;
1999 }
9850bf21 2000 return 0;
d7507f74 2001 }
9850bf21 2002
a0d0e21e 2003 POPBLOCK(cx,newpm);
6b35e009 2004 switch (CxTYPE(cx)) {
a0d0e21e 2005 case CXt_SUB:
f86702cc 2006 popsub2 = TRUE;
f39bc417 2007 retop = cx->blk_sub.retop;
5dd42e15 2008 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 2009 break;
2010 case CXt_EVAL:
b45de488
GS		 2011 if (!(PL_in_eval & EVAL_KEEPERR))
2012 clear_errsv = TRUE;
a0d0e21e 2013 POPEVAL(cx);
f39bc417 2014 retop = cx->blk_eval.retop;
1d76a5c3
GS		 2015 if (CxTRYBLOCK(cx))
2016 break;
067f92a0 2017 lex_end();
748a9306
LW		 2018 if (optype == OP_REQUIRE &&
2019 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2020 {
54310121 2021 /* Unassume the success we assumed earlier. */
901017d6 2022 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 2023 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
be2597df 2024 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
748a9306 2025 }
a0d0e21e 2026 break;
7766f137
GS		 2027 case CXt_FORMAT:
2028 POPFORMAT(cx);
f39bc417 2029 retop = cx->blk_sub.retop;
7766f137 2030 break;
a0d0e21e 2031 default:
cea2e8a9 2032 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 2033 }
2034
a1f49e72 2035 TAINT_NOT;
a0d0e21e 2036 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2037 if (MARK < SP) {
2038 if (popsub2) {
a8bba7fa 2039 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 2040 if (SvTEMP(TOPs)) {
2041 *++newsp = SvREFCNT_inc(*SP);
2042 FREETMPS;
2043 sv_2mortal(*newsp);
959e3673
GS		 2044 }
2045 else {
2046 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2047 FREETMPS;
959e3673
GS		 2048 *++newsp = sv_mortalcopy(sv);
2049 SvREFCNT_dec(sv);
a29cdaf0 2050 }
959e3673
GS		 2051 }
2052 else
a29cdaf0 2053 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2054 }
2055 else
a29cdaf0 2056 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2057 }
2058 else
3280af22 2059 *++newsp = &PL_sv_undef;
a0d0e21e 2060 }
54310121 2061 else if (gimme == G_ARRAY) {
a1f49e72 2062 while (++MARK <= SP) {
f86702cc 2063 *++newsp = (popsub2 && SvTEMP(*MARK))
2064 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2065 TAINT_NOT; /* Each item is independent */
2066 }
a0d0e21e 2067 }
3280af22 2068 PL_stack_sp = newsp;
a0d0e21e 2069
5dd42e15 2070 LEAVE;
f86702cc 2071 /* Stack values are safe: */
2072 if (popsub2) {
5dd42e15 2073 cxstack_ix--;
b0d9ce38 2074 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2075 }
b0d9ce38 2076 else
c445ea15 2077 sv = NULL;
3280af22 2078 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2079
b0d9ce38 2080 LEAVESUB(sv);
b45de488 2081 if (clear_errsv)
c69006e4 2082 sv_setpvn(ERRSV,"",0);
f39bc417 2083 return retop;
a0d0e21e
LW		 2084}
2085
2086PP(pp_last)
2087{
27da23d5 2088 dVAR; dSP;
a0d0e21e 2089 I32 cxix;
c09156bb 2090 register PERL_CONTEXT *cx;
f86702cc 2091 I32 pop2 = 0;
a0d0e21e 2092 I32 gimme;
8772537c 2093 I32 optype;
a0d0e21e
LW		 2094 OP *nextop;
2095 SV **newsp;
2096 PMOP *newpm;
a8bba7fa 2097 SV **mark;
c445ea15 2098 SV *sv = NULL;
9d4ba2ae 2099
a0d0e21e 2100
533c011a 2101 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2102 cxix = dopoptoloop(cxstack_ix);
2103 if (cxix < 0)
a651a37d 2104 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2105 }
2106 else {
2107 cxix = dopoptolabel(cPVOP->op_pv);
2108 if (cxix < 0)
cea2e8a9 2109 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2110 }
2111 if (cxix < cxstack_ix)
2112 dounwind(cxix);
2113
2114 POPBLOCK(cx,newpm);
5dd42e15 2115 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2116 mark = newsp;
6b35e009 2117 switch (CxTYPE(cx)) {
a0d0e21e 2118 case CXt_LOOP:
f86702cc 2119 pop2 = CXt_LOOP;
a8bba7fa 2120 newsp = PL_stack_base + cx->blk_loop.resetsp;
022eaa24 2121 nextop = cx->blk_loop.my_op->op_lastop->op_next;
a0d0e21e 2122 break;
f86702cc 2123 case CXt_SUB:
f86702cc 2124 pop2 = CXt_SUB;
f39bc417 2125 nextop = cx->blk_sub.retop;
a0d0e21e 2126 break;
f86702cc 2127 case CXt_EVAL:
2128 POPEVAL(cx);
f39bc417 2129 nextop = cx->blk_eval.retop;
a0d0e21e 2130 break;
7766f137
GS		 2131 case CXt_FORMAT:
2132 POPFORMAT(cx);
f39bc417 2133 nextop = cx->blk_sub.retop;
7766f137 2134 break;
a0d0e21e 2135 default:
cea2e8a9 2136 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2137 }
2138
a1f49e72 2139 TAINT_NOT;
a0d0e21e 2140 if (gimme == G_SCALAR) {
f86702cc 2141 if (MARK < SP)
2142 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2143 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2144 else
3280af22 2145 *++newsp = &PL_sv_undef;
a0d0e21e 2146 }
54310121 2147 else if (gimme == G_ARRAY) {
a1f49e72 2148 while (++MARK <= SP) {
f86702cc 2149 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2150 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2151 TAINT_NOT; /* Each item is independent */
2152 }
f86702cc 2153 }
2154 SP = newsp;
2155 PUTBACK;
2156
5dd42e15
DM		 2157 LEAVE;
2158 cxstack_ix--;
f86702cc 2159 /* Stack values are safe: */
2160 switch (pop2) {
2161 case CXt_LOOP:
a8bba7fa 2162 POPLOOP(cx); /* release loop vars ... */
4fdae800 2163 LEAVE;
f86702cc 2164 break;
2165 case CXt_SUB:
b0d9ce38 2166 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2167 break;
a0d0e21e 2168 }
3280af22 2169 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2170
b0d9ce38 2171 LEAVESUB(sv);
9d4ba2ae
AL		 2172 PERL_UNUSED_VAR(optype);
2173 PERL_UNUSED_VAR(gimme);
f86702cc 2174 return nextop;
a0d0e21e
LW		 2175}
2176
2177PP(pp_next)
2178{
27da23d5 2179 dVAR;
a0d0e21e 2180 I32 cxix;
c09156bb 2181 register PERL_CONTEXT *cx;
85538317 2182 I32 inner;
a0d0e21e 2183
533c011a 2184 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2185 cxix = dopoptoloop(cxstack_ix);
2186 if (cxix < 0)
a651a37d 2187 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2188 }
2189 else {
2190 cxix = dopoptolabel(cPVOP->op_pv);
2191 if (cxix < 0)
cea2e8a9 2192 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2193 }
2194 if (cxix < cxstack_ix)
2195 dounwind(cxix);
2196
85538317
GS		 2197 /* clear off anything above the scope we're re-entering, but
2198 * save the rest until after a possible continue block */
2199 inner = PL_scopestack_ix;
1ba6ee2b 2200 TOPBLOCK(cx);
85538317
GS		 2201 if (PL_scopestack_ix < inner)
2202 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2203 PL_curcop = cx->blk_oldcop;
022eaa24 2204 return CX_LOOP_NEXTOP_GET(cx);
a0d0e21e
LW		 2205}
2206
2207PP(pp_redo)
2208{
27da23d5 2209 dVAR;
a0d0e21e 2210 I32 cxix;
c09156bb 2211 register PERL_CONTEXT *cx;
a0d0e21e 2212 I32 oldsave;
a034e688 2213 OP* redo_op;
a0d0e21e 2214
533c011a 2215 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2216 cxix = dopoptoloop(cxstack_ix);
2217 if (cxix < 0)
a651a37d 2218 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2219 }
2220 else {
2221 cxix = dopoptolabel(cPVOP->op_pv);
2222 if (cxix < 0)
cea2e8a9 2223 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2224 }
2225 if (cxix < cxstack_ix)
2226 dounwind(cxix);
2227
022eaa24 2228 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
a034e688
DM		 2229 if (redo_op->op_type == OP_ENTER) {
2230 /* pop one less context to avoid $x being freed in while (my $x..) */
2231 cxstack_ix++;
2232 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2233 redo_op = redo_op->op_next;
2234 }
2235
a0d0e21e 2236 TOPBLOCK(cx);
3280af22 2237 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2238 LEAVE_SCOPE(oldsave);
936c78b5 2239 FREETMPS;
3a1b2b9e 2240 PL_curcop = cx->blk_oldcop;
a034e688 2241 return redo_op;
a0d0e21e
LW		 2242}
2243
0824fdcb 2244STATIC OP *
bfed75c6 2245S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2246{
97aff369 2247 dVAR;
a0d0e21e 2248 OP **ops = opstack;
bfed75c6 2249 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2250
fc36a67e 2251 if (ops >= oplimit)
cea2e8a9 2252 Perl_croak(aTHX_ too_deep);
11343788
MB		 2253 if (o->op_type == OP_LEAVE ||
2254 o->op_type == OP_SCOPE ||
2255 o->op_type == OP_LEAVELOOP ||
33d34e4c 2256 o->op_type == OP_LEAVESUB ||
11343788 2257 o->op_type == OP_LEAVETRY)
fc36a67e 2258 {
5dc0d613 2259 *ops++ = cUNOPo->op_first;
fc36a67e 2260 if (ops >= oplimit)
cea2e8a9 2261 Perl_croak(aTHX_ too_deep);
fc36a67e 2262 }
c4aa4e48 2263 *ops = 0;
11343788 2264 if (o->op_flags & OPf_KIDS) {
aec46f14 2265 OP *kid;
a0d0e21e 2266 /* First try all the kids at this level, since that's likeliest. */
11343788 2267 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2268 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2269 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2270 return kid;
2271 }
11343788 2272 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2273 if (kid == PL_lastgotoprobe)
a0d0e21e 2274 continue;
ed8d0fe2
SM		 2275 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2276 if (ops == opstack)
2277 *ops++ = kid;
2278 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2279 ops[-1]->op_type == OP_DBSTATE)
2280 ops[-1] = kid;
2281 else
2282 *ops++ = kid;
2283 }
155aba94 2284 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2285 return o;
a0d0e21e
LW		 2286 }
2287 }
c4aa4e48 2288 *ops = 0;
a0d0e21e
LW		 2289 return 0;
2290}
2291
a0d0e21e
LW		 2292PP(pp_goto)
2293{
27da23d5 2294 dVAR; dSP;
cbbf8932 2295 OP *retop = NULL;
a0d0e21e 2296 I32 ix;
c09156bb 2297 register PERL_CONTEXT *cx;
fc36a67e 2298#define GOTO_DEPTH 64
2299 OP *enterops[GOTO_DEPTH];
cbbf8932 2300 const char *label = NULL;
bfed75c6
AL		 2301 const bool do_dump = (PL_op->op_type == OP_DUMP);
2302 static const char must_have_label[] = "goto must have label";
a0d0e21e 2303
533c011a 2304 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2305 SV * const sv = POPs;
a0d0e21e
LW		 2306
2307 /* This egregious kludge implements goto &subroutine */
2308 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2309 I32 cxix;
c09156bb 2310 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2311 CV* cv = (CV*)SvRV(sv);
2312 SV** mark;
2313 I32 items = 0;
2314 I32 oldsave;
b1464ded 2315 bool reified = 0;
a0d0e21e 2316
e8f7dd13 2317 retry:
4aa0a1f7 2318 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2319 const GV * const gv = CvGV(cv);
e8f7dd13 2320 if (gv) {
7fc63493 2321 GV *autogv;
e8f7dd13
GS		 2322 SV *tmpstr;
2323 /* autoloaded stub? */
2324 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2325 goto retry;
2326 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2327 GvNAMELEN(gv), FALSE);
2328 if (autogv && (cv = GvCV(autogv)))
2329 goto retry;
2330 tmpstr = sv_newmortal();
c445ea15 2331 gv_efullname3(tmpstr, gv, NULL);
be2597df 2332 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
4aa0a1f7 2333 }
cea2e8a9 2334 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2335 }
2336
a0d0e21e 2337 /* First do some returnish stuff. */
b37c2d43 2338 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
71fc2216 2339 FREETMPS;
a0d0e21e
LW		 2340 cxix = dopoptosub(cxstack_ix);
2341 if (cxix < 0)
cea2e8a9 2342 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2343 if (cxix < cxstack_ix)
2344 dounwind(cxix);
2345 TOPBLOCK(cx);
2d43a17f 2346 SPAGAIN;
564abe23 2347 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2348 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2349 if (CxREALEVAL(cx))
2350 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2351 else
2352 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2353 }
9850bf21
RH		 2354 else if (CxMULTICALL(cx))
2355 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
cc8d50a7 2356 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
d8b46c1b 2357 /* put @_ back onto stack */
a0d0e21e 2358 AV* av = cx->blk_sub.argarray;
bfed75c6 2359
93965878 2360 items = AvFILLp(av) + 1;
a45cdc79
DM		 2361 EXTEND(SP, items+1); /* @_ could have been extended. */
2362 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2363 SvREFCNT_dec(GvAV(PL_defgv));
2364 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2365 CLEAR_ARGARRAY(av);
d8b46c1b 2366 /* abandon @_ if it got reified */
62b1ebc2 2367 if (AvREAL(av)) {
b1464ded
DM		 2368 reified = 1;
2369 SvREFCNT_dec(av);
d8b46c1b
GS		 2370 av = newAV();
2371 av_extend(av, items-1);
11ca45c0 2372 AvREIFY_only(av);
dd2155a4 2373 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2374 }
a0d0e21e 2375 }
aed2304a 2376 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2377 AV* const av = GvAV(PL_defgv);
1fa4e549 2378 items = AvFILLp(av) + 1;
a45cdc79
DM		 2379 EXTEND(SP, items+1); /* @_ could have been extended. */
2380 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2381 }
a45cdc79
DM		 2382 mark = SP;
2383 SP += items;
6b35e009 2384 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2385 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2386 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2387 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2388 LEAVE_SCOPE(oldsave);
2389
2390 /* Now do some callish stuff. */
2391 SAVETMPS;
5023d17a 2392 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2393 if (CvISXSUB(cv)) {
b37c2d43 2394 OP* const retop = cx->blk_sub.retop;
f73ef291
NC		 2395 SV **newsp;
2396 I32 gimme;
b1464ded
DM		 2397 if (reified) {
2398 I32 index;
2399 for (index=0; index<items; index++)
2400 sv_2mortal(SP[-index]);
2401 }
1fa4e549 2402
b37c2d43
AL		 2403 /* XS subs don't have a CxSUB, so pop it */
2404 POPBLOCK(cx, PL_curpm);
2405 /* Push a mark for the start of arglist */
2406 PUSHMARK(mark);
2407 PUTBACK;
2408 (void)(*CvXSUB(cv))(aTHX_ cv);
a0d0e21e 2409 LEAVE;
5eff7df7 2410 return retop;
a0d0e21e
LW		 2411 }
2412 else {
b37c2d43 2413 AV* const padlist = CvPADLIST(cv);
6b35e009 2414 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2415 PL_in_eval = cx->blk_eval.old_in_eval;
2416 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22 2417 cx->cx_type = CXt_SUB;
cc8d50a7 2418 cx->blk_sub.hasargs = 0;
b150fb22 2419 }
a0d0e21e 2420 cx->blk_sub.cv = cv;
1a5b3db4 2421 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2422
a0d0e21e
LW		 2423 CvDEPTH(cv)++;
2424 if (CvDEPTH(cv) < 2)
74c765eb 2425 SvREFCNT_inc_simple_void_NN(cv);
dd2155a4 2426 else {
599cee73 2427 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2428 sub_crush_depth(cv);
26019298 2429 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2430 }
fd617465
DM		 2431 SAVECOMPPAD();
2432 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
cc8d50a7 2433 if (cx->blk_sub.hasargs)
6d4ff0d2 2434 {
b37c2d43 2435 AV* const av = (AV*)PAD_SVl(0);
a0d0e21e 2436
3280af22 2437 cx->blk_sub.savearray = GvAV(PL_defgv);
b37c2d43 2438 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
dd2155a4 2439 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2440 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2441
2442 if (items >= AvMAX(av) + 1) {
b37c2d43 2443 SV **ary = AvALLOC(av);
a0d0e21e
LW		 2444 if (AvARRAY(av) != ary) {
2445 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2446 AvARRAY(av) = ary;
a0d0e21e
LW		 2447 }
2448 if (items >= AvMAX(av) + 1) {
2449 AvMAX(av) = items - 1;
2450 Renew(ary,items+1,SV*);
2451 AvALLOC(av) = ary;
9c6bc640 2452 AvARRAY(av) = ary;
a0d0e21e
LW		 2453 }
2454 }
a45cdc79 2455 ++mark;
a0d0e21e 2456 Copy(mark,AvARRAY(av),items,SV*);
93965878 2457 AvFILLp(av) = items - 1;
d8b46c1b 2458 assert(!AvREAL(av));
b1464ded
DM		 2459 if (reified) {
2460 /* transfer 'ownership' of refcnts to new @_ */
2461 AvREAL_on(av);
2462 AvREIFY_off(av);
2463 }
a0d0e21e
LW		 2464 while (items--) {
2465 if (*mark)
2466 SvTEMP_off(*mark);
2467 mark++;
2468 }
2469 }
491527d0 2470 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
005a8a35 2471 Perl_get_db_sub(aTHX_ NULL, cv);
b37c2d43
AL		 2472 if (PERLDB_GOTO) {
2473 CV * const gotocv = get_cv("DB::goto", FALSE);
2474 if (gotocv) {
2475 PUSHMARK( PL_stack_sp );
2476 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2477 PL_stack_sp--;
2478 }
491527d0 2479 }
1ce6579f 2480 }
a0d0e21e
LW		 2481 RETURNOP(CvSTART(cv));
2482 }
2483 }
1614b0e3 2484 else {
0510663f 2485 label = SvPV_nolen_const(sv);
1614b0e3 2486 if (!(do_dump || *label))
cea2e8a9 2487 DIE(aTHX_ must_have_label);
1614b0e3 2488 }
a0d0e21e 2489 }
533c011a 2490 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2491 if (! do_dump)
cea2e8a9 2492 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2493 }
2494 else
2495 label = cPVOP->op_pv;
2496
2497 if (label && *label) {
cbbf8932 2498 OP *gotoprobe = NULL;
3b2447bc 2499 bool leaving_eval = FALSE;
33d34e4c 2500 bool in_block = FALSE;
cbbf8932 2501 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW		 2502
2503 /* find label */
2504
d4c19fe8 2505 PL_lastgotoprobe = NULL;
a0d0e21e
LW		 2506 *enterops = 0;
2507 for (ix = cxstack_ix; ix >= 0; ix--) {
2508 cx = &cxstack[ix];
6b35e009 2509 switch (CxTYPE(cx)) {
a0d0e21e 2510 case CXt_EVAL:
3b2447bc 2511 leaving_eval = TRUE;
971ecbe6 2512 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2513 gotoprobe = (last_eval_cx ?
2514 last_eval_cx->blk_eval.old_eval_root :
2515 PL_eval_root);
2516 last_eval_cx = cx;
9c5794fe
RH		 2517 break;
2518 }
2519 /* else fall through */
a0d0e21e
LW		 2520 case CXt_LOOP:
2521 gotoprobe = cx->blk_oldcop->op_sibling;
2522 break;
2523 case CXt_SUBST:
2524 continue;
2525 case CXt_BLOCK:
33d34e4c 2526 if (ix) {
a0d0e21e 2527 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2528 in_block = TRUE;
2529 } else
3280af22 2530 gotoprobe = PL_main_root;
a0d0e21e 2531 break;
b3933176 2532 case CXt_SUB:
9850bf21 2533 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS		 2534 gotoprobe = CvROOT(cx->blk_sub.cv);
2535 break;
2536 }
2537 /* FALL THROUGH */
7766f137 2538 case CXt_FORMAT:
0a753a76 2539 case CXt_NULL:
a651a37d 2540 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2541 default:
2542 if (ix)
cea2e8a9 2543 DIE(aTHX_ "panic: goto");
3280af22 2544 gotoprobe = PL_main_root;
a0d0e21e
LW		 2545 break;
2546 }
2b597662
GS		 2547 if (gotoprobe) {
2548 retop = dofindlabel(gotoprobe, label,
2549 enterops, enterops + GOTO_DEPTH);
2550 if (retop)
2551 break;
2552 }
3280af22 2553 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2554 }
2555 if (!retop)
cea2e8a9 2556 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2557
3b2447bc
RH		 2558 /* if we're leaving an eval, check before we pop any frames
2559 that we're not going to punt, otherwise the error
2560 won't be caught */
2561
2562 if (leaving_eval && *enterops && enterops[1]) {
2563 I32 i;
2564 for (i = 1; enterops[i]; i++)
2565 if (enterops[i]->op_type == OP_ENTERITER)
2566 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2567 }
2568
a0d0e21e
LW		 2569 /* pop unwanted frames */
2570
2571 if (ix < cxstack_ix) {
2572 I32 oldsave;
2573
2574 if (ix < 0)
2575 ix = 0;
2576 dounwind(ix);
2577 TOPBLOCK(cx);
3280af22 2578 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2579 LEAVE_SCOPE(oldsave);
2580 }
2581
2582 /* push wanted frames */
2583
748a9306 2584 if (*enterops && enterops[1]) {
0bd48802 2585 OP * const oldop = PL_op;
33d34e4c
AE		 2586 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2587 for (; enterops[ix]; ix++) {
533c011a 2588 PL_op = enterops[ix];
84902520
TB		 2589 /* Eventually we may want to stack the needed arguments
2590 * for each op. For now, we punt on the hard ones. */
533c011a 2591 if (PL_op->op_type == OP_ENTERITER)
894356b3 2592 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2593 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2594 }
533c011a 2595 PL_op = oldop;
a0d0e21e
LW		 2596 }
2597 }
2598
2599 if (do_dump) {
a5f75d66 2600#ifdef VMS
6b88bc9c 2601 if (!retop) retop = PL_main_start;
a5f75d66 2602#endif
3280af22
NIS		 2603 PL_restartop = retop;
2604 PL_do_undump = TRUE;
a0d0e21e
LW		 2605
2606 my_unexec();
2607
3280af22
NIS		 2608 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2609 PL_do_undump = FALSE;
a0d0e21e
LW		 2610 }
2611
2612 RETURNOP(retop);
2613}
2614
2615PP(pp_exit)
2616{
97aff369 2617 dVAR;
39644a26 2618 dSP;
a0d0e21e
LW		 2619 I32 anum;
2620
2621 if (MAXARG < 1)
2622 anum = 0;
ff0cee69 2623 else {
a0d0e21e 2624 anum = SvIVx(POPs);
d98f61e7
GS		 2625#ifdef VMS
2626 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2627 anum = 0;
96e176bf 2628 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2629#endif
2630 }
cc3604b1 2631 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC		 2632#ifdef PERL_MAD
2633 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2634 if (anum || !(PL_minus_c && PL_madskills))
2635 my_exit(anum);
2636#else
a0d0e21e 2637 my_exit(anum);
81d86705 2638#endif
3280af22 2639 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2640 RETURN;
2641}
2642
a0d0e21e
LW		 2643/* Eval. */
2644
0824fdcb 2645STATIC void
cea2e8a9 2646S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2647{
504618e9 2648 const char *s = SvPVX_const(sv);
890ce7af 2649 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2650 I32 line = 1;
a0d0e21e
LW		 2651
2652 while (s && s < send) {
f54cb97a 2653 const char *t;
b9f83d2f 2654 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 2655
a0d0e21e
LW		 2656 t = strchr(s, '\n');
2657 if (t)
2658 t++;
2659 else
2660 t = send;
2661
2662 sv_setpvn(tmpstr, s, t - s);
2663 av_store(array, line++, tmpstr);
2664 s = t;
2665 }
2666}
2667
901017d6 2668STATIC void
14dd3ad8
GS		 2669S_docatch_body(pTHX)
2670{
97aff369 2671 dVAR;
cea2e8a9 2672 CALLRUNOPS(aTHX);
901017d6 2673 return;
312caa8e
CS		 2674}
2675
0824fdcb 2676STATIC OP *
cea2e8a9 2677S_docatch(pTHX_ OP *o)
1e422769 2678{
97aff369 2679 dVAR;
6224f72b 2680 int ret;
06b5626a 2681 OP * const oldop = PL_op;
db36c5a1 2682 dJMPENV;
1e422769 2683
1e422769 2684#ifdef DEBUGGING
54310121 2685 assert(CATCH_GET == TRUE);
1e422769 2686#endif
312caa8e 2687 PL_op = o;
8bffa5f8 2688
14dd3ad8 2689 JMPENV_PUSH(ret);
6224f72b 2690 switch (ret) {
312caa8e 2691 case 0:
abd70938
DM		 2692 assert(cxstack_ix >= 0);
2693 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2694 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2695 redo_body:
2696 docatch_body();
312caa8e
CS		 2697 break;
2698 case 3:
8bffa5f8 2699 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2700
2701 /* NB XXX we rely on the old popped CxEVAL still being at the top
2702 * of the stack; the way die_where() currently works, this
2703 * assumption is valid. In theory The cur_top_env value should be
2704 * returned in another global, the way retop (aka PL_restartop)
2705 * is. */
2706 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2707
2708 if (PL_restartop
2709 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2710 {
312caa8e
CS		 2711 PL_op = PL_restartop;
2712 PL_restartop = 0;
2713 goto redo_body;
2714 }
2715 /* FALL THROUGH */
2716 default:
14dd3ad8 2717 JMPENV_POP;
533c011a 2718 PL_op = oldop;
6224f72b 2719 JMPENV_JUMP(ret);
1e422769 2720 /* NOTREACHED */
1e422769 2721 }
14dd3ad8 2722 JMPENV_POP;
533c011a 2723 PL_op = oldop;
5f66b61c 2724 return NULL;
1e422769 2725}
2726
c277df42 2727OP *
bfed75c6 2728Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2729/* sv Text to convert to OP tree. */
2730/* startop op_free() this to undo. */
2731/* code Short string id of the caller. */
2732{
f7997f86 2733 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2734 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2735 PERL_CONTEXT *cx;
2736 SV **newsp;
b094c71d 2737 I32 gimme = G_VOID;
c277df42
IZ		 2738 I32 optype;
2739 OP dummy;
83ee9e09
GS		 2740 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741 char *tmpbuf = tbuf;
c277df42 2742 char *safestr;
a3985cdc 2743 int runtime;
601f1833 2744 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 2745 STRLEN len;
c277df42
IZ		 2746
2747 ENTER;
5486870f 2748 lex_start(sv, NULL, FALSE);
c277df42
IZ		 2749 SAVETMPS;
2750 /* switch to eval mode */
2751
923e4eb5 2752 if (IN_PERL_COMPILETIME) {
f4dd75d9 2753 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2754 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2755 }
83ee9e09 2756 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2757 SV * const sv = sv_newmortal();
83ee9e09
GS		 2758 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2759 code, (unsigned long)++PL_evalseq,
2760 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2761 tmpbuf = SvPVX(sv);
fc009855 2762 len = SvCUR(sv);
83ee9e09
GS		 2763 }
2764 else
d9fad198
JH		 2765 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2766 (unsigned long)++PL_evalseq);
f4dd75d9 2767 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2768 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2769 SAVECOPLINE(&PL_compiling);
57843af0 2770 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2771 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2772 deleting the eval's FILEGV from the stash before gv_check() runs
2773 (i.e. before run-time proper). To work around the coredump that
2774 ensues, we always turn GvMULTI_on for any globals that were
2775 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 2776 safestr = savepvn(tmpbuf, len);
2777 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2778 SAVEHINTS();
d1ca3daa 2779#ifdef OP_IN_REGISTER
6b88bc9c 2780 PL_opsave = op;
d1ca3daa 2781#else
7766f137 2782 SAVEVPTR(PL_op);
d1ca3daa 2783#endif
c277df42 2784
a3985cdc 2785 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2786 runtime = IN_PERL_RUNTIME;
a3985cdc 2787 if (runtime)
d819b83a 2788 runcv = find_runcv(NULL);
a3985cdc 2789
533c011a 2790 PL_op = &dummy;
13b51b79 2791 PL_op->op_type = OP_ENTEREVAL;
533c011a 2792 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2793 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
a0714e2c 2794 PUSHEVAL(cx, 0, NULL);
a3985cdc
DM		 2795
2796 if (runtime)
410be5db 2797 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
a3985cdc 2798 else
410be5db 2799 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2800 POPBLOCK(cx,PL_curpm);
e84b9f1f 2801 POPEVAL(cx);
c277df42
IZ		 2802
2803 (*startop)->op_type = OP_NULL;
22c35a8c 2804 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2805 lex_end();
f3548bdc 2806 /* XXX DAPM do this properly one year */
b37c2d43 2807 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
c277df42 2808 LEAVE;
923e4eb5 2809 if (IN_PERL_COMPILETIME)
623e6609 2810 CopHINTS_set(&PL_compiling, PL_hints);
d1ca3daa 2811#ifdef OP_IN_REGISTER
6b88bc9c 2812 op = PL_opsave;
d1ca3daa 2813#endif
9d4ba2ae
AL		 2814 PERL_UNUSED_VAR(newsp);
2815 PERL_UNUSED_VAR(optype);
2816
410be5db 2817 return PL_eval_start;
c277df42
IZ		 2818}
2819
a3985cdc
DM		 2820
2821/*
2822=for apidoc find_runcv
2823
2824Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2825If db_seqp is non_null, skip CVs that are in the DB package and populate
2826*db_seqp with the cop sequence number at the point that the DB:: code was
2827entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2828than in the scope of the debugger itself).
a3985cdc
DM		 2829
2830=cut
2831*/
2832
2833CV*
d819b83a 2834Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2835{
97aff369 2836 dVAR;
a3985cdc 2837 PERL_SI *si;
a3985cdc 2838
d819b83a
DM		 2839 if (db_seqp)
2840 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2841 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2842 I32 ix;
a3985cdc 2843 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2844 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2845 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2846 CV * const cv = cx->blk_sub.cv;
d819b83a
DM		 2847 /* skip DB:: code */
2848 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2849 *db_seqp = cx->blk_oldcop->cop_seq;
2850 continue;
2851 }
2852 return cv;
2853 }
a3985cdc
DM		 2854 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2855 return PL_compcv;
2856 }
2857 }
2858 return PL_main_cv;
2859}
2860
2861
2862/* Compile a require/do, an eval '', or a /(?{...})/.
2863 * In the last case, startop is non-null, and contains the address of
2864 * a pointer that should be set to the just-compiled code.
2865 * outside is the lexically enclosing CV (if any) that invoked us.
410be5db
DM		 2866 * Returns a bool indicating whether the compile was successful; if so,
2867 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2868 * pushes undef (also croaks if startop != NULL).
a3985cdc
DM		 2869 */
2870
410be5db 2871STATIC bool
a3985cdc 2872S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2873{
27da23d5 2874 dVAR; dSP;
46c461b5 2875 OP * const saveop = PL_op;
a0d0e21e 2876
6dc8a9e4
IZ		 2877 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2878 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2879 : EVAL_INEVAL);
a0d0e21e 2880
1ce6579f 2881 PUSHMARK(SP);
2882
3280af22 2883 SAVESPTR(PL_compcv);
b9f83d2f 2884 PL_compcv = (CV*)newSV_type(SVt_PVCV);
1aff0e91 2885 CvEVAL_on(PL_compcv);
2090ab20
JH		 2886 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2887 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2888
a3985cdc 2889 CvOUTSIDE_SEQ(PL_compcv) = seq;
b37c2d43 2890 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
a3985cdc 2891
dd2155a4 2892 /* set up a scratch pad */
a0d0e21e 2893
dd2155a4 2894 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
cecbe010 2895 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2c05e328 2896
07055b4c 2897
81d86705
NC		 2898 if (!PL_madskills)
2899 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2900
a0d0e21e
LW		 2901 /* make sure we compile in the right package */
2902
ed094faf 2903 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2904 SAVESPTR(PL_curstash);
ed094faf 2905 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2906 }
3c10abe3 2907 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3280af22
NIS		 2908 SAVESPTR(PL_beginav);
2909 PL_beginav = newAV();
2910 SAVEFREESV(PL_beginav);
3c10abe3
AG		 2911 SAVESPTR(PL_unitcheckav);
2912 PL_unitcheckav = newAV();
2913 SAVEFREESV(PL_unitcheckav);
a0d0e21e 2914
81d86705 2915#ifdef PERL_MAD
9da243ce 2916 SAVEBOOL(PL_madskills);
81d86705
NC		 2917 PL_madskills = 0;
2918#endif
2919
a0d0e21e
LW		 2920 /* try to compile it */
2921
5f66b61c 2922 PL_eval_root = NULL;
3280af22 2923 PL_curcop = &PL_compiling;
fc15ae8f 2924 CopARYBASE_set(PL_curcop, 0);
5f66b61c 2925 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 2926 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2927 else
c69006e4 2928 sv_setpvn(ERRSV,"",0);
13765c85 2929 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
0c58d367 2930 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2931 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2932 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2933 const char *msg;
bfed75c6 2934
533c011a 2935 PL_op = saveop;
3280af22
NIS		 2936 if (PL_eval_root) {
2937 op_free(PL_eval_root);
5f66b61c 2938 PL_eval_root = NULL;
a0d0e21e 2939 }
3280af22 2940 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2941 if (!startop) {
3280af22 2942 POPBLOCK(cx,PL_curpm);
c277df42 2943 POPEVAL(cx);
c277df42 2944 }
a0d0e21e
LW		 2945 lex_end();
2946 LEAVE;
9d4ba2ae
AL		 2947
2948 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2949 if (optype == OP_REQUIRE) {
b464bac0 2950 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2951 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2952 &PL_sv_undef, 0);
58d3fd3b
SH		 2953 Perl_croak(aTHX_ "%sCompilation failed in require",
2954 *msg ? msg : "Unknown error\n");
5a844595
GS		 2955 }
2956 else if (startop) {
3280af22 2957 POPBLOCK(cx,PL_curpm);
c277df42 2958 POPEVAL(cx);
5a844595
GS		 2959 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2960 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2961 }
9d7f88dd 2962 else {
9d7f88dd 2963 if (!*msg) {
6502358f 2964 sv_setpvs(ERRSV, "Compilation error");
9d7f88dd
SR		 2965 }
2966 }
9d4ba2ae 2967 PERL_UNUSED_VAR(newsp);
410be5db
DM		 2968 PUSHs(&PL_sv_undef);
2969 PUTBACK;
2970 return FALSE;
a0d0e21e 2971 }
57843af0 2972 CopLINE_set(&PL_compiling, 0);
c277df42 2973 if (startop) {
3280af22 2974 *startop = PL_eval_root;
c277df42 2975 } else
3280af22 2976 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2977
2978 /* Set the context for this new optree.
2979 * If the last op is an OP_REQUIRE, force scalar context.
2980 * Otherwise, propagate the context from the eval(). */
2981 if (PL_eval_root->op_type == OP_LEAVEEVAL
2982 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2983 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2984 == OP_REQUIRE)
2985 scalar(PL_eval_root);
2986 else if (gimme & G_VOID)
3280af22 2987 scalarvoid(PL_eval_root);
54310121 2988 else if (gimme & G_ARRAY)
3280af22 2989 list(PL_eval_root);
a0d0e21e 2990 else
3280af22 2991 scalar(PL_eval_root);
a0d0e21e
LW		 2992
2993 DEBUG_x(dump_eval());
2994
55497cff 2995 /* Register with debugger: */
6482a30d 2996 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
890ce7af 2997 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff 2998 if (cv) {
2999 dSP;
924508f0 3000 PUSHMARK(SP);
cc49e20b 3001 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 3002 PUTBACK;
864dbfa3 3003 call_sv((SV*)cv, G_DISCARD);
55497cff 3004 }
3005 }
3006
3c10abe3
AG		 3007 if (PL_unitcheckav)
3008 call_list(PL_scopestack_ix, PL_unitcheckav);
3009
a0d0e21e
LW		 3010 /* compiled okay, so do it */
3011
3280af22
NIS		 3012 CvDEPTH(PL_compcv) = 1;
3013 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3014 PL_op = saveop; /* The caller may need it. */
bc177e6b 3015 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3016
410be5db
DM		 3017 PUTBACK;
3018 return TRUE;
a0d0e21e
LW		 3019}
3020
a6c40364 3021STATIC PerlIO *
74d5ed12 3022S_check_type_and_open(pTHX_ const char *name, const char *mode)
ce8abf5f
SP		 3023{
3024 Stat_t st;
c445ea15 3025 const int st_rc = PerlLIO_stat(name, &st);
df528165 3026
6b845e56 3027 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
4608196e 3028 return NULL;
ce8abf5f
SP		 3029 }
3030
ce8abf5f
SP		 3031 return PerlIO_open(name, mode);
3032}
3033
3034STATIC PerlIO *
7925835c 3035S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3036{
7925835c 3037#ifndef PERL_DISABLE_PMC
f54cb97a 3038 const STRLEN namelen = strlen(name);
b295d113
TH		 3039 PerlIO *fp;
3040
7894fbab 3041 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3042 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3043 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS		 3044 Stat_t pmcstat;
3045 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
85e8f315 3046 fp = check_type_and_open(name, mode);
a6c40364
GS		 3047 }
3048 else {
a91233bf 3049 fp = check_type_and_open(pmc, mode);
b295d113 3050 }
a6c40364
GS		 3051 SvREFCNT_dec(pmcsv);
3052 }
3053 else {
85e8f315 3054 fp = check_type_and_open(name, mode);
b295d113 3055 }
b295d113 3056 return fp;
7925835c 3057#else
85e8f315 3058 return check_type_and_open(name, mode);
7925835c 3059#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3060}
3061
a0d0e21e
LW		 3062PP(pp_require)
3063{
27da23d5 3064 dVAR; dSP;
c09156bb 3065 register PERL_CONTEXT *cx;
a0d0e21e 3066 SV *sv;
5c144d81 3067 const char *name;
6132ea6c 3068 STRLEN len;
4492be7a
JM		 3069 char * unixname;
3070 STRLEN unixlen;
62f5ad7a 3071#ifdef VMS
4492be7a 3072 int vms_unixname = 0;
62f5ad7a 3073#endif
c445ea15
AL		 3074 const char *tryname = NULL;
3075 SV *namesv = NULL;
f54cb97a 3076 const I32 gimme = GIMME_V;
bbed91b5 3077 int filter_has_file = 0;
c445ea15 3078 PerlIO *tryrsfp = NULL;
34113e50 3079 SV *filter_cache = NULL;
c445ea15
AL		 3080 SV *filter_state = NULL;
3081 SV *filter_sub = NULL;
3082 SV *hook_sv = NULL;
6ec9efec
JH		 3083 SV *encoding;
3084 OP *op;
a0d0e21e
LW		 3085
3086 sv = POPs;
d7aa5382
JP		 3087 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3088 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3089 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3090 "v-string in use/require non-portable");
d7aa5382
JP		 3091
3092 sv = new_version(sv);
3093 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3094 upg_version(PL_patchlevel, TRUE);
149c1637 3095 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3cacfbb9 3096 if ( vcmp(sv,PL_patchlevel) <= 0 )
468aa647 3097 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
be2597df 3098 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
468aa647
RGS		 3099 }
3100 else {
3101 if ( vcmp(sv,PL_patchlevel) > 0 )
3102 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
be2597df 3103 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
468aa647 3104 }
d7aa5382 3105
7dfde25d
RGS		 3106 /* If we request a version >= 5.9.5, load feature.pm with the
3107 * feature bundle that corresponds to the required version.
3108 * We do this only with use, not require. */
ac0e6a2f 3109 if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
7dfde25d
RGS		 3110 SV *const importsv = vnormal(sv);
3111 *SvPVX_mutable(importsv) = ':';
3112 ENTER;
3113 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3114 LEAVE;
3115 }
3116
3117 RETPUSHYES;
a0d0e21e 3118 }
5c144d81 3119 name = SvPV_const(sv, len);
6132ea6c 3120 if (!(name && len > 0 && *name))
cea2e8a9 3121 DIE(aTHX_ "Null filename used");
4633a7c4 3122 TAINT_PROPER("require");
4492be7a
JM		 3123
3124
3125#ifdef VMS
3126 /* The key in the %ENV hash is in the syntax of file passed as the argument
3127 * usually this is in UNIX format, but sometimes in VMS format, which
3128 * can result in a module being pulled in more than once.
3129 * To prevent this, the key must be stored in UNIX format if the VMS
3130 * name can be translated to UNIX.
3131 */
3132 if ((unixname = tounixspec(name, NULL)) != NULL) {
3133 unixlen = strlen(unixname);
3134 vms_unixname = 1;
3135 }
3136 else
3137#endif
3138 {
3139 /* if not VMS or VMS name can not be translated to UNIX, pass it
3140 * through.
3141 */
3142 unixname = (char *) name;
3143 unixlen = len;
3144 }
44f8325f 3145 if (PL_op->op_type == OP_REQUIRE) {
4492be7a
JM		 3146 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3147 unixname, unixlen, 0);
44f8325f
AL		 3148 if ( svp ) {
3149 if (*svp != &PL_sv_undef)
3150 RETPUSHYES;
3151 else
3152 DIE(aTHX_ "Compilation failed in require");
3153 }
4d8b06f1 3154 }
a0d0e21e
LW		 3155
3156 /* prepare to compile file */
3157
be4b629d 3158 if (path_is_absolute(name)) {
46fc3d4c 3159 tryname = name;
7925835c 3160 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3161 }
67627c52
JH		 3162#ifdef MACOS_TRADITIONAL
3163 if (!tryrsfp) {
3164 char newname[256];
3165
3166 MacPerl_CanonDir(name, newname, 1);
3167 if (path_is_absolute(newname)) {
3168 tryname = newname;
7925835c 3169 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3170 }
3171 }
3172#endif
be4b629d 3173 if (!tryrsfp) {
44f8325f 3174 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3175 I32 i;
748a9306 3176#ifdef VMS
4492be7a 3177 if (vms_unixname)
46fc3d4c 3178#endif
3179 {
561b68a9 3180 namesv = newSV(0);
46fc3d4c 3181 for (i = 0; i <= AvFILL(ar); i++) {
df528165 3182 SV * const dirsv = *av_fetch(ar, i, TRUE);
bbed91b5 3183
c38a6530
RD		 3184 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3185 mg_get(dirsv);
bbed91b5
KF		 3186 if (SvROK(dirsv)) {
3187 int count;
a3b58a99 3188 SV **svp;
bbed91b5
KF		 3189 SV *loader = dirsv;
3190
e14e2dc8
NC		 3191 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3192 && !sv_isobject(loader))
3193 {
bbed91b5
KF		 3194 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3195 }
3196
b900a521 3197 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3198 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3199 tryname = SvPVX_const(namesv);
c445ea15 3200 tryrsfp = NULL;
bbed91b5
KF		 3201
3202 ENTER;
3203 SAVETMPS;
3204 EXTEND(SP, 2);
3205
3206 PUSHMARK(SP);
3207 PUSHs(dirsv);
3208 PUSHs(sv);
3209 PUTBACK;
e982885c
NC		 3210 if (sv_isobject(loader))
3211 count = call_method("INC", G_ARRAY);
3212 else
3213 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3214 SPAGAIN;
3215
a3b58a99
RGS		 3216 /* Adjust file name if the hook has set an %INC entry */
3217 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3218 if (svp)
3219 tryname = SvPVX_const(*svp);
3220
bbed91b5
KF		 3221 if (count > 0) {
3222 int i = 0;
3223 SV *arg;
3224
3225 SP -= count - 1;
3226 arg = SP[i++];
3227
34113e50
NC		 3228 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3229 && !isGV_with_GP(SvRV(arg))) {
3230 filter_cache = SvRV(arg);
74c765eb 3231 SvREFCNT_inc_simple_void_NN(filter_cache);
34113e50
NC		 3232
3233 if (i < count) {
3234 arg = SP[i++];
3235 }
3236 }
3237
bbed91b5
KF		 3238 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3239 arg = SvRV(arg);
3240 }
3241
3242 if (SvTYPE(arg) == SVt_PVGV) {
df528165 3243 IO * const io = GvIO((GV *)arg);
bbed91b5
KF		 3244
3245 ++filter_has_file;
3246
3247 if (io) {
3248 tryrsfp = IoIFP(io);
0f7de14d
NC		 3249 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3250 PerlIO_close(IoOFP(io));
bbed91b5 3251 }
0f7de14d
NC		 3252 IoIFP(io) = NULL;
3253 IoOFP(io) = NULL;
bbed91b5
KF		 3254 }
3255
3256 if (i < count) {
3257 arg = SP[i++];
3258 }
3259 }
3260
3261 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3262 filter_sub = arg;
74c765eb 3263 SvREFCNT_inc_simple_void_NN(filter_sub);
bbed91b5
KF		 3264
3265 if (i < count) {
3266 filter_state = SP[i];
b37c2d43 3267 SvREFCNT_inc_simple_void(filter_state);
bbed91b5 3268 }
34113e50 3269 }
bbed91b5 3270
34113e50
NC		 3271 if (!tryrsfp && (filter_cache || filter_sub)) {
3272 tryrsfp = PerlIO_open(BIT_BUCKET,
3273 PERL_SCRIPT_MODE);
bbed91b5 3274 }
1d06aecd 3275 SP--;
bbed91b5
KF		 3276 }
3277
3278 PUTBACK;
3279 FREETMPS;
3280 LEAVE;
3281
3282 if (tryrsfp) {
89ccab8c 3283 hook_sv = dirsv;
bbed91b5
KF		 3284 break;
3285 }
3286
3287 filter_has_file = 0;
34113e50
NC		 3288 if (filter_cache) {
3289 SvREFCNT_dec(filter_cache);
3290 filter_cache = NULL;
3291 }
bbed91b5
KF		 3292 if (filter_state) {
3293 SvREFCNT_dec(filter_state);
c445ea15 3294 filter_state = NULL;
bbed91b5
KF		 3295 }
3296 if (filter_sub) {
3297 SvREFCNT_dec(filter_sub);
c445ea15 3298 filter_sub = NULL;
bbed91b5
KF		 3299 }
3300 }
3301 else {
be4b629d
CN		 3302 if (!path_is_absolute(name)
3303#ifdef MACOS_TRADITIONAL
3304 /* We consider paths of the form :a:b ambiguous and interpret them first
3305 as global then as local
3306 */
3307 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3308#endif
3309 ) {
089d5d59 3310 const char *dir = SvOK(dirsv) ? SvPV_nolen_const(dirsv) : "";
bf4acbe4 3311#ifdef MACOS_TRADITIONAL
67627c52
JH		 3312 char buf1[256];
3313 char buf2[256];
3314
3315 MacPerl_CanonDir(name, buf2, 1);
3316 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3317#else
27da23d5 3318# ifdef VMS
bbed91b5 3319 char *unixdir;
c445ea15 3320 if ((unixdir = tounixpath(dir, NULL)) == NULL)
bbed91b5
KF		 3321 continue;
3322 sv_setpv(namesv, unixdir);
3323 sv_catpv(namesv, unixname);
27da23d5 3324# else
a0fd4948 3325# ifdef __SYMBIAN32__
27da23d5
JH		 3326 if (PL_origfilename[0] &&
3327 PL_origfilename[1] == ':' &&
3328 !(dir[0] && dir[1] == ':'))
3329 Perl_sv_setpvf(aTHX_ namesv,
3330 "%c:%s\\%s",
3331 PL_origfilename[0],
3332 dir, name);
3333 else
3334 Perl_sv_setpvf(aTHX_ namesv,
3335 "%s\\%s",
3336 dir, name);
3337# else
bbed91b5 3338 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH		 3339# endif
3340# endif
bf4acbe4 3341#endif
bbed91b5 3342 TAINT_PROPER("require");
349d4f2f 3343 tryname = SvPVX_const(namesv);
7925835c 3344 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3345 if (tryrsfp) {
3346 if (tryname[0] == '.' && tryname[1] == '/')
3347 tryname += 2;
3348 break;
3349 }
ff806af2
DM		 3350 else if (errno == EMFILE)
3351 /* no point in trying other paths if out of handles */
3352 break;
be4b629d 3353 }
46fc3d4c 3354 }
a0d0e21e
LW		 3355 }
3356 }
3357 }
f4dd75d9 3358 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3359 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3360 SvREFCNT_dec(namesv);
a0d0e21e 3361 if (!tryrsfp) {
533c011a 3362 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3363 const char *msgstr = name;
e31de809 3364 if(errno == EMFILE) {
b9b739dc
NC		 3365 SV * const msg
3366 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3367 Strerror(errno)));
349d4f2f 3368 msgstr = SvPV_nolen_const(msg);
e31de809
SP		 3369 } else {
3370 if (namesv) { /* did we lookup @INC? */
44f8325f 3371 AV * const ar = GvAVn(PL_incgv);
e31de809 3372 I32 i;
b8f04b1b
NC		 3373 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3374 "%s in @INC%s%s (@INC contains:",
3375 msgstr,
3376 (instr(msgstr, ".h ")
3377 ? " (change .h to .ph maybe?)" : ""),
3378 (instr(msgstr, ".ph ")
3379 ? " (did you run h2ph?)" : "")
3380 ));
3381
e31de809 3382 for (i = 0; i <= AvFILL(ar); i++) {
396482e1 3383 sv_catpvs(msg, " ");
b8f04b1b 3384 sv_catsv(msg, *av_fetch(ar, i, TRUE));
e31de809 3385 }
396482e1 3386 sv_catpvs(msg, ")");
e31de809
SP		 3387 msgstr = SvPV_nolen_const(msg);
3388 }
2683423c 3389 }
ea071790 3390 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3391 }
3392
3393 RETPUSHUNDEF;
3394 }
d8bfb8bd 3395 else
93189314 3396 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3397
3398 /* Assume success here to prevent recursive requirement. */
238d24b4 3399 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 3400 /* Check whether a hook in @INC has already filled %INC */
44f8325f 3401 if (!hook_sv) {
4492be7a
JM		 3402 (void)hv_store(GvHVn(PL_incgv),
3403 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
44f8325f 3404 } else {
4492be7a 3405 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
44f8325f 3406 if (!svp)
4492be7a
JM		 3407 (void)hv_store(GvHVn(PL_incgv),
3408 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
d3a4e64e 3409 }
a0d0e21e
LW		 3410
3411 ENTER;
3412 SAVETMPS;
5486870f 3413 lex_start(NULL, tryrsfp, TRUE);
e50aee73 3414
b3ac6de7 3415 SAVEHINTS();
3280af22 3416 PL_hints = 0;
68da3b2f 3417 SAVECOMPILEWARNINGS();
0453d815 3418 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3419 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3420 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3421 PL_compiling.cop_warnings = pWARN_NONE ;
ac27b0f5 3422 else
d3a7d8c7 3423 PL_compiling.cop_warnings = pWARN_STD ;
a0d0e21e 3424
34113e50 3425 if (filter_sub || filter_cache) {
c445ea15 3426 SV * const datasv = filter_add(S_run_user_filter, NULL);
bbed91b5 3427 IoLINES(datasv) = filter_has_file;
bbed91b5
KF		 3428 IoTOP_GV(datasv) = (GV *)filter_state;
3429 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
34113e50 3430 IoFMT_GV(datasv) = (GV *)filter_cache;
bbed91b5
KF		 3431 }
3432
3433 /* switch to eval mode */
a0d0e21e 3434 PUSHBLOCK(cx, CXt_EVAL, SP);
a0714e2c 3435 PUSHEVAL(cx, name, NULL);
f39bc417 3436 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3437
57843af0
GS		 3438 SAVECOPLINE(&PL_compiling);
3439 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3440
3441 PUTBACK;
6ec9efec
JH		 3442
3443 /* Store and reset encoding. */
3444 encoding = PL_encoding;
c445ea15 3445 PL_encoding = NULL;
6ec9efec 3446
410be5db
DM		 3447 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3448 op = DOCATCH(PL_eval_start);
3449 else
3450 op = PL_op->op_next;
bfed75c6 3451
6ec9efec
JH		 3452 /* Restore encoding. */
3453 PL_encoding = encoding;
3454
3455 return op;
a0d0e21e
LW		 3456}
3457
a0d0e21e
LW		 3458PP(pp_entereval)
3459{
27da23d5 3460 dVAR; dSP;
c09156bb 3461 register PERL_CONTEXT *cx;
0d863452 3462 SV *sv;
890ce7af
AL		 3463 const I32 gimme = GIMME_V;
3464 const I32 was = PL_sub_generation;
83ee9e09
GS		 3465 char tbuf[TYPE_DIGITS(long) + 12];
3466 char *tmpbuf = tbuf;
fc36a67e 3467 char *safestr;
a0d0e21e 3468 STRLEN len;
410be5db 3469 bool ok;
a3985cdc 3470 CV* runcv;
d819b83a 3471 U32 seq;
c445ea15 3472 HV *saved_hh = NULL;
e80fed9d 3473 const char * const fakestr = "_<(eval )";
e80fed9d 3474 const int fakelen = 9 + 1;
0d863452
RH		 3475
3476 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3477 saved_hh = (HV*) SvREFCNT_inc(POPs);
3478 }
3479 sv = POPs;
a0d0e21e 3480
af2d3def 3481 TAINT_IF(SvTAINTED(sv));
748a9306 3482 TAINT_PROPER("eval");
a0d0e21e
LW		 3483
3484 ENTER;
5486870f 3485 lex_start(sv, NULL, FALSE);
748a9306 3486 SAVETMPS;
ac27b0f5 3487
a0d0e21e
LW		 3488 /* switch to eval mode */
3489
83ee9e09 3490 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
8b38226b
AL		 3491 SV * const temp_sv = sv_newmortal();
3492 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
83ee9e09
GS		 3493 (unsigned long)++PL_evalseq,
3494 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8b38226b
AL		 3495 tmpbuf = SvPVX(temp_sv);
3496 len = SvCUR(temp_sv);
83ee9e09
GS		 3497 }
3498 else
d9fad198 3499 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3500 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3501 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3502 SAVECOPLINE(&PL_compiling);
57843af0 3503 CopLINE_set(&PL_compiling, 1);
55497cff 3504 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3505 deleting the eval's FILEGV from the stash before gv_check() runs
3506 (i.e. before run-time proper). To work around the coredump that
3507 ensues, we always turn GvMULTI_on for any globals that were
3508 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 3509 safestr = savepvn(tmpbuf, len);
3510 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 3511 SAVEHINTS();
533c011a 3512 PL_hints = PL_op->op_targ;
0d863452
RH		 3513 if (saved_hh)
3514 GvHV(PL_hintgv) = saved_hh;
68da3b2f 3515 SAVECOMPILEWARNINGS();
72dc9ed5 3516 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 3517 if (PL_compiling.cop_hints_hash) {
3518 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
a24d89c9 3519 }
c28fe1ec
NC		 3520 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3521 if (PL_compiling.cop_hints_hash) {
cbb1fbea 3522 HINTS_REFCNT_LOCK;
c28fe1ec 3523 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 3524 HINTS_REFCNT_UNLOCK;
a24d89c9 3525 }
d819b83a
DM		 3526 /* special case: an eval '' executed within the DB package gets lexically
3527 * placed in the first non-DB CV rather than the current CV - this
3528 * allows the debugger to execute code, find lexicals etc, in the
3529 * scope of the code being debugged. Passing &seq gets find_runcv
3530 * to do the dirty work for us */
3531 runcv = find_runcv(&seq);
a0d0e21e 3532
6b35e009 3533 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
a0714e2c 3534 PUSHEVAL(cx, 0, NULL);
f39bc417 3535 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 3536
3537 /* prepare to compile string */
3538
3280af22 3539 if (PERLDB_LINE && PL_curstash != PL_debstash)
bdc0bf6f 3540 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
a0d0e21e 3541 PUTBACK;
410be5db 3542 ok = doeval(gimme, NULL, runcv, seq);
eb160463 3543 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
410be5db 3544 && ok) {
e80fed9d 3545 /* Copy in anything fake and short. */
28f0d0ec 3546 my_strlcpy(safestr, fakestr, fakelen);
55497cff 3547 }
410be5db 3548 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
a0d0e21e
LW		 3549}
3550
3551PP(pp_leaveeval)
3552{
27da23d5 3553 dVAR; dSP;
a0d0e21e
LW		 3554 register SV **mark;
3555 SV **newsp;
3556 PMOP *newpm;
3557 I32 gimme;
c09156bb 3558 register PERL_CONTEXT *cx;
a0d0e21e 3559 OP *retop;
06b5626a 3560 const U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3561 I32 optype;
3562
3563 POPBLOCK(cx,newpm);
3564 POPEVAL(cx);
f39bc417 3565 retop = cx->blk_eval.retop;
a0d0e21e 3566
a1f49e72 3567 TAINT_NOT;
54310121 3568 if (gimme == G_VOID)
3569 MARK = newsp;
3570 else if (gimme == G_SCALAR) {
3571 MARK = newsp + 1;
3572 if (MARK <= SP) {
3573 if (SvFLAGS(TOPs) & SVs_TEMP)
3574 *MARK = TOPs;
3575 else
3576 *MARK = sv_mortalcopy(TOPs);
3577 }
a0d0e21e 3578 else {
54310121 3579 MEXTEND(mark,0);
3280af22 3580 *MARK = &PL_sv_undef;
a0d0e21e 3581 }
a7ec2b44 3582 SP = MARK;
a0d0e21e
LW		 3583 }
3584 else {
a1f49e72
CS		 3585 /* in case LEAVE wipes old return values */
3586 for (mark = newsp + 1; mark <= SP; mark++) {
3587 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3588 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3589 TAINT_NOT; /* Each item is independent */
3590 }
3591 }
a0d0e21e 3592 }
3280af22 3593 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3594
4fdae800 3595#ifdef DEBUGGING
3280af22 3596 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3597#endif
3280af22 3598 CvDEPTH(PL_compcv) = 0;
f46d017c 3599 lex_end();
4fdae800 3600
1ce6579f 3601 if (optype == OP_REQUIRE &&
924508f0 3602 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3603 {
1ce6579f 3604 /* Unassume the success we assumed earlier. */
901017d6 3605 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 3606 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
be2597df 3607 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
f46d017c
GS		 3608 /* die_where() did LEAVE, or we won't be here */
3609 }
3610 else {
3611 LEAVE;
3612 if (!(save_flags & OPf_SPECIAL))
c69006e4 3613 sv_setpvn(ERRSV,"",0);
a0d0e21e 3614 }
a0d0e21e
LW		 3615
3616 RETURNOP(retop);
3617}
3618
edb2152a
NC		 3619/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3620 close to the related Perl_create_eval_scope. */
3621void
3622Perl_delete_eval_scope(pTHX)
a0d0e21e 3623{
edb2152a
NC		 3624 SV **newsp;
3625 PMOP *newpm;
3626 I32 gimme;
c09156bb 3627 register PERL_CONTEXT *cx;
edb2152a
NC		 3628 I32 optype;
3629
3630 POPBLOCK(cx,newpm);
3631 POPEVAL(cx);
3632 PL_curpm = newpm;
3633 LEAVE;
3634 PERL_UNUSED_VAR(newsp);
3635 PERL_UNUSED_VAR(gimme);
3636 PERL_UNUSED_VAR(optype);
3637}
a0d0e21e 3638
edb2152a
NC		 3639/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3640 also needed by Perl_fold_constants. */
3641PERL_CONTEXT *
3642Perl_create_eval_scope(pTHX_ U32 flags)
3643{
3644 PERL_CONTEXT *cx;
3645 const I32 gimme = GIMME_V;
3646
a0d0e21e
LW		 3647 ENTER;
3648 SAVETMPS;
3649
edb2152a 3650 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
a0d0e21e 3651 PUSHEVAL(cx, 0, 0);
a0d0e21e 3652
faef0170 3653 PL_in_eval = EVAL_INEVAL;
edb2152a
NC		 3654 if (flags & G_KEEPERR)
3655 PL_in_eval |= EVAL_KEEPERR;
3656 else
3657 sv_setpvn(ERRSV,"",0);
3658 if (flags & G_FAKINGEVAL) {
3659 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3660 }
3661 return cx;
3662}
3663
3664PP(pp_entertry)
3665{
3666 dVAR;
df528165 3667 PERL_CONTEXT * const cx = create_eval_scope(0);
edb2152a 3668 cx->blk_eval.retop = cLOGOP->op_other->op_next;
533c011a 3669 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3670}
3671
3672PP(pp_leavetry)
3673{
27da23d5 3674 dVAR; dSP;
a0d0e21e
LW		 3675 SV **newsp;
3676 PMOP *newpm;
3677 I32 gimme;
c09156bb 3678 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3679 I32 optype;
3680
3681 POPBLOCK(cx,newpm);
3682 POPEVAL(cx);
9d4ba2ae 3683 PERL_UNUSED_VAR(optype);
a0d0e21e 3684
a1f49e72 3685 TAINT_NOT;
54310121 3686 if (gimme == G_VOID)
3687 SP = newsp;
3688 else if (gimme == G_SCALAR) {
c445ea15 3689 register SV **mark;
54310121 3690 MARK = newsp + 1;
3691 if (MARK <= SP) {
3692 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3693 *MARK = TOPs;
3694 else
3695 *MARK = sv_mortalcopy(TOPs);
3696 }
a0d0e21e 3697 else {
54310121 3698 MEXTEND(mark,0);
3280af22 3699 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3700 }
3701 SP = MARK;
3702 }
3703 else {
a1f49e72 3704 /* in case LEAVE wipes old return values */
c445ea15 3705 register SV **mark;
a1f49e72
CS		 3706 for (mark = newsp + 1; mark <= SP; mark++) {
3707 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3708 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3709 TAINT_NOT; /* Each item is independent */
3710 }
3711 }
a0d0e21e 3712 }
3280af22 3713 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3714
3715 LEAVE;
c69006e4 3716 sv_setpvn(ERRSV,"",0);
745cf2ff 3717 RETURN;
a0d0e21e
LW		 3718}
3719
0d863452
RH		 3720PP(pp_entergiven)
3721{
3722 dVAR; dSP;
3723 register PERL_CONTEXT *cx;
3724 const I32 gimme = GIMME_V;
3725
3726 ENTER;
3727 SAVETMPS;
3728
3729 if (PL_op->op_targ == 0) {
c445ea15 3730 SV ** const defsv_p = &GvSV(PL_defgv);
0d863452
RH		 3731 *defsv_p = newSVsv(POPs);
3732 SAVECLEARSV(*defsv_p);
3733 }
3734 else
3735 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3736
3737 PUSHBLOCK(cx, CXt_GIVEN, SP);
3738 PUSHGIVEN(cx);
3739
3740 RETURN;
3741}
3742
3743PP(pp_leavegiven)
3744{
3745 dVAR; dSP;
3746 register PERL_CONTEXT *cx;
3747 I32 gimme;
3748 SV **newsp;
3749 PMOP *newpm;
96a5add6 3750 PERL_UNUSED_CONTEXT;
0d863452
RH		 3751
3752 POPBLOCK(cx,newpm);
3753 assert(CxTYPE(cx) == CXt_GIVEN);
0d863452
RH		 3754
3755 SP = newsp;
3756 PUTBACK;
3757
3758 PL_curpm = newpm; /* pop $1 et al */
3759
3760 LEAVE;
3761
3762 return NORMAL;
3763}
3764
3765/* Helper routines used by pp_smartmatch */
4136a0f7 3766STATIC PMOP *
0d863452
RH		 3767S_make_matcher(pTHX_ regexp *re)
3768{
97aff369 3769 dVAR;
0d863452
RH		 3770 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3771 PM_SETRE(matcher, ReREFCNT_inc(re));
3772
3773 SAVEFREEOP((OP *) matcher);
3774 ENTER; SAVETMPS;
3775 SAVEOP();
3776 return matcher;
3777}
3778
4136a0f7 3779STATIC bool
0d863452
RH		 3780S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3781{
97aff369 3782 dVAR;
0d863452
RH		 3783 dSP;
3784
3785 PL_op = (OP *) matcher;
3786 XPUSHs(sv);
3787 PUTBACK;
3788 (void) pp_match();
3789 SPAGAIN;
3790 return (SvTRUEx(POPs));
3791}
3792
4136a0f7 3793STATIC void
0d863452
RH		 3794S_destroy_matcher(pTHX_ PMOP *matcher)
3795{
97aff369 3796 dVAR;
0d863452
RH		 3797 PERL_UNUSED_ARG(matcher);
3798 FREETMPS;
3799 LEAVE;
3800}
3801
3802/* Do a smart match */
3803PP(pp_smartmatch)
3804{
a0714e2c 3805 return do_smartmatch(NULL, NULL);
0d863452
RH		 3806}
3807
4b021f5f
RGS		 3808/* This version of do_smartmatch() implements the
3809 * table of smart matches that is found in perlsyn.
0d863452 3810 */
4136a0f7 3811STATIC OP *
0d863452
RH		 3812S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3813{
97aff369 3814 dVAR;
0d863452
RH		 3815 dSP;
3816
3817 SV *e = TOPs; /* e is for 'expression' */
3818 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
10edeb5d 3819 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
0d863452
RH		 3820 MAGIC *mg;
3821 regexp *this_regex, *other_regex;
3822
3823# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3824
3825# define SM_REF(type) ( \
10edeb5d
JH		 3826 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3827 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
0d863452
RH		 3828
3829# define SM_CV_NEP /* Find a code ref without an empty prototype */ \
10edeb5d
JH		 3830 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3831 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3832 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3833 && NOT_EMPTY_PROTO(This) && (Other = d)))
0d863452
RH		 3834
3835# define SM_REGEX ( \
10edeb5d
JH		 3836 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3837 && (mg = mg_find(This, PERL_MAGIC_qr)) \
0d863452 3838 && (this_regex = (regexp *)mg->mg_obj) \
10edeb5d 3839 && (Other = e)) \
0d863452 3840 || \
10edeb5d
JH		 3841 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3842 && (mg = mg_find(This, PERL_MAGIC_qr)) \
0d863452 3843 && (this_regex = (regexp *)mg->mg_obj) \
10edeb5d 3844 && (Other = d)) )
0d863452
RH		 3845
3846
3847# define SM_OTHER_REF(type) \
10edeb5d 3848 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
0d863452 3849
10edeb5d
JH		 3850# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3851 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
0d863452
RH		 3852 && (other_regex = (regexp *)mg->mg_obj))
3853
3854
3855# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
98f4023c 3856 sv_2mortal(newSViv(PTR2IV(sv))), 0)
0d863452
RH		 3857
3858# define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
98f4023c 3859 sv_2mortal(newSViv(PTR2IV(sv))), 0)
0d863452
RH		 3860
3861 tryAMAGICbinSET(smart, 0);
3862
3863 SP -= 2; /* Pop the values */
3864
3865 /* Take care only to invoke mg_get() once for each argument.
3866 * Currently we do this by copying the SV if it's magical. */
3867 if (d) {
3868 if (SvGMAGICAL(d))
3869 d = sv_mortalcopy(d);
3870 }
3871 else
3872 d = &PL_sv_undef;
3873
3874 assert(e);
3875 if (SvGMAGICAL(e))
3876 e = sv_mortalcopy(e);
3877
3878 if (SM_CV_NEP) {
3879 I32 c;
3880
10edeb5d 3881 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
0d863452 3882 {
10edeb5d 3883 if (This == SvRV(Other))
0d863452
RH		 3884 RETPUSHYES;
3885 else
3886 RETPUSHNO;
3887 }
3888
3889 ENTER;
3890 SAVETMPS;
3891 PUSHMARK(SP);
10edeb5d 3892 PUSHs(Other);
0d863452 3893 PUTBACK;
10edeb5d 3894 c = call_sv(This, G_SCALAR);
0d863452
RH		 3895 SPAGAIN;
3896 if (c == 0)
3897 PUSHs(&PL_sv_no);
3898 else if (SvTEMP(TOPs))
df528165 3899 SvREFCNT_inc_void(TOPs);
0d863452
RH		 3900 FREETMPS;
3901 LEAVE;
3902 RETURN;
3903 }
3904 else if (SM_REF(PVHV)) {
3905 if (SM_OTHER_REF(PVHV)) {
3906 /* Check that the key-sets are identical */
3907 HE *he;
10edeb5d 3908 HV *other_hv = (HV *) SvRV(Other);
0d863452
RH		 3909 bool tied = FALSE;
3910 bool other_tied = FALSE;
3911 U32 this_key_count = 0,
3912 other_key_count = 0;
3913
3914 /* Tied hashes don't know how many keys they have. */
10edeb5d 3915 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
0d863452
RH		 3916 tied = TRUE;
3917 }
3918 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
c445ea15 3919 HV * const temp = other_hv;
10edeb5d
JH		 3920 other_hv = (HV *) This;
3921 This = (SV *) temp;
0d863452
RH		 3922 tied = TRUE;
3923 }
3924 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3925 other_tied = TRUE;
3926
10edeb5d 3927 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
0d863452
RH		 3928 RETPUSHNO;
3929
3930 /* The hashes have the same number of keys, so it suffices
3931 to check that one is a subset of the other. */
10edeb5d
JH		 3932 (void) hv_iterinit((HV *) This);
3933 while ( (he = hv_iternext((HV *) This)) ) {
0d863452 3934 I32 key_len;
c445ea15 3935 char * const key = hv_iterkey(he, &key_len);
0d863452
RH		 3936
3937 ++ this_key_count;
3938
3939 if(!hv_exists(other_hv, key, key_len)) {
10edeb5d 3940 (void) hv_iterinit((HV *) This); /* reset iterator */
0d863452
RH		 3941 RETPUSHNO;
3942 }
3943 }
3944
3945 if (other_tied) {
3946 (void) hv_iterinit(other_hv);
3947 while ( hv_iternext(other_hv) )
3948 ++other_key_count;
3949 }
3950 else
3951 other_key_count = HvUSEDKEYS(other_hv);
3952
3953 if (this_key_count != other_key_count)
3954 RETPUSHNO;
3955 else
3956 RETPUSHYES;
3957 }
3958 else if (SM_OTHER_REF(PVAV)) {
10edeb5d 3959 AV * const other_av = (AV *) SvRV(Other);
c445ea15 3960 const I32 other_len = av_len(other_av) + 1;
0d863452
RH		 3961 I32 i;
3962
10edeb5d 3963 if (HvUSEDKEYS((HV *) This) != other_len)
0d863452
RH		 3964 RETPUSHNO;
3965
3966 for(i = 0; i < other_len; ++i) {
c445ea15 3967 SV ** const svp = av_fetch(other_av, i, FALSE);
0d863452
RH		 3968 char *key;
3969 STRLEN key_len;
3970
3971 if (!svp) /* ??? When can this happen? */
3972 RETPUSHNO;
3973
3974 key = SvPV(*svp, key_len);
10edeb5d 3975 if(!hv_exists((HV *) This, key, key_len))
0d863452
RH		 3976 RETPUSHNO;
3977 }
3978 RETPUSHYES;
3979 }
3980 else if (SM_OTHER_REGEX) {
c445ea15 3981 PMOP * const matcher = make_matcher(other_regex);
0d863452
RH		 3982 HE *he;
3983
10edeb5d
JH		 3984 (void) hv_iterinit((HV *) This);
3985 while ( (he = hv_iternext((HV *) This)) ) {
0d863452 3986 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
10edeb5d 3987 (void) hv_iterinit((HV *) This);
0d863452
RH		 3988 destroy_matcher(matcher);
3989 RETPUSHYES;
3990 }
3991 }
3992 destroy_matcher(matcher);
3993 RETPUSHNO;
3994 }
3995 else {
10edeb5d 3996 if (hv_exists_ent((HV *) This, Other, 0))
0d863452
RH		 3997 RETPUSHYES;
3998 else
3999 RETPUSHNO;
4000 }
4001 }
4002 else if (SM_REF(PVAV)) {
4003 if (SM_OTHER_REF(PVAV)) {
10edeb5d
JH		 4004 AV *other_av = (AV *) SvRV(Other);
4005 if (av_len((AV *) This) != av_len(other_av))
0d863452
RH		 4006 RETPUSHNO;
4007 else {
4008 I32 i;
c445ea15 4009 const I32 other_len = av_len(other_av);
0d863452 4010
a0714e2c 4011 if (NULL == seen_this) {
0d863452
RH		 4012 seen_this = newHV();
4013 (void) sv_2mortal((SV *) seen_this);
4014 }
a0714e2c 4015 if (NULL == seen_other) {
0d863452
RH		 4016 seen_this = newHV();
4017 (void) sv_2mortal((SV *) seen_other);
4018 }
4019 for(i = 0; i <= other_len; ++i) {
10edeb5d 4020 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
c445ea15
AL		 4021 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4022
0d863452
RH		 4023 if (!this_elem || !other_elem) {
4024 if (this_elem || other_elem)
4025 RETPUSHNO;
4026 }
4027 else if (SM_SEEN_THIS(*this_elem)
4028 || SM_SEEN_OTHER(*other_elem))
4029 {
4030 if (*this_elem != *other_elem)
4031 RETPUSHNO;
4032 }
4033 else {
4034 hv_store_ent(seen_this,
98f4023c 4035 sv_2mortal(newSViv(PTR2IV(*this_elem))),
0d863452
RH		 4036 &PL_sv_undef, 0);
4037 hv_store_ent(seen_other,
98f4023c 4038 sv_2mortal(newSViv(PTR2IV(*other_elem))),
0d863452
RH		 4039 &PL_sv_undef, 0);
4040 PUSHs(*this_elem);
4041 PUSHs(*other_elem);
4042
4043 PUTBACK;
4044 (void) do_smartmatch(seen_this, seen_other);
4045 SPAGAIN;
4046
4047 if (!SvTRUEx(POPs))
4048 RETPUSHNO;
4049 }
4050 }
4051 RETPUSHYES;
4052 }
4053 }
4054 else if (SM_OTHER_REGEX) {
c445ea15 4055 PMOP * const matcher = make_matcher(other_regex);
10edeb5d 4056 const I32 this_len = av_len((AV *) This);
0d863452 4057 I32 i;
0d863452
RH		 4058
4059 for(i = 0; i <= this_len; ++i) {
10edeb5d 4060 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
0d863452
RH		 4061 if (svp && matcher_matches_sv(matcher, *svp)) {
4062 destroy_matcher(matcher);
4063 RETPUSHYES;
4064 }
4065 }
4066 destroy_matcher(matcher);
4067 RETPUSHNO;
4068 }
10edeb5d 4069 else if (SvIOK(Other) || SvNOK(Other)) {
0d863452
RH		 4070 I32 i;
4071
10edeb5d
JH		 4072 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4073 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
0d863452
RH		 4074 if (!svp)
4075 continue;
4076
10edeb5d 4077 PUSHs(Other);
0d863452
RH		 4078 PUSHs(*svp);
4079 PUTBACK;
a98fe34d 4080 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
0d863452
RH		 4081 (void) pp_i_eq();
4082 else
4083 (void) pp_eq();
4084 SPAGAIN;
4085 if (SvTRUEx(POPs))
4086 RETPUSHYES;
4087 }
4088 RETPUSHNO;
4089 }
10edeb5d
JH		 4090 else if (SvPOK(Other)) {
4091 const I32 this_len = av_len((AV *) This);
0d863452 4092 I32 i;
0d863452
RH		 4093
4094 for(i = 0; i <= this_len; ++i) {
10edeb5d 4095 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
0d863452
RH		 4096 if (!svp)
4097 continue;
4098
10edeb5d 4099 PUSHs(Other);
0d863452
RH		 4100 PUSHs(*svp);
4101 PUTBACK;
4102 (void) pp_seq();
4103 SPAGAIN;
4104 if (SvTRUEx(POPs))
4105 RETPUSHYES;
4106 }
4107 RETPUSHNO;
4108 }
4109 }
4110 else if (!SvOK(d) || !SvOK(e)) {
4111 if (!SvOK(d) && !SvOK(e))
4112 RETPUSHYES;
4113 else
4114 RETPUSHNO;
4115 }
4116 else if (SM_REGEX) {
c445ea15 4117 PMOP * const matcher = make_matcher(this_regex);
0d863452
RH		 4118
4119 PUTBACK;
10edeb5d 4120 PUSHs(matcher_matches_sv(matcher, Other)
0d863452
RH		 4121 ? &PL_sv_yes
4122 : &PL_sv_no);
4123 destroy_matcher(matcher);
4124 RETURN;
4125 }
4126 else if (SM_REF(PVCV)) {
4127 I32 c;
4128 /* This must be a null-prototyped sub, because we
4129 already checked for the other kind. */
4130
4131 ENTER;
4132 SAVETMPS;
4133 PUSHMARK(SP);
4134 PUTBACK;
10edeb5d 4135 c = call_sv(This, G_SCALAR);
0d863452
RH		 4136 SPAGAIN;
4137 if (c == 0)
4138 PUSHs(&PL_sv_undef);
4139 else if (SvTEMP(TOPs))
df528165 4140 SvREFCNT_inc_void(TOPs);
0d863452
RH		 4141
4142 if (SM_OTHER_REF(PVCV)) {
4143 /* This one has to be null-proto'd too.
4144 Call both of 'em, and compare the results */
4145 PUSHMARK(SP);
10edeb5d 4146 c = call_sv(SvRV(Other), G_SCALAR);
0d863452
RH		 4147 SPAGAIN;
4148 if (c == 0)
4149 PUSHs(&PL_sv_undef);
4150 else if (SvTEMP(TOPs))
df528165 4151 SvREFCNT_inc_void(TOPs);
0d863452
RH		 4152 FREETMPS;
4153 LEAVE;
4154 PUTBACK;
4155 return pp_eq();
4156 }
4157
4158 FREETMPS;
4159 LEAVE;
4160 RETURN;
4161 }
10edeb5d
JH		 4162 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4163 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
0d863452 4164 {
10edeb5d 4165 if (SvPOK(Other) && !looks_like_number(Other)) {
0d863452
RH		 4166 /* String comparison */
4167 PUSHs(d); PUSHs(e);
4168 PUTBACK;
4169 return pp_seq();
4170 }
4171 /* Otherwise, numeric comparison */
4172 PUSHs(d); PUSHs(e);
4173 PUTBACK;
a98fe34d 4174 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
0d863452
RH		 4175 (void) pp_i_eq();
4176 else
4177 (void) pp_eq();
4178 SPAGAIN;
4179 if (SvTRUEx(POPs))
4180 RETPUSHYES;
4181 else
4182 RETPUSHNO;
4183 }
4184
4185 /* As a last resort, use string comparison */
4186 PUSHs(d); PUSHs(e);
4187 PUTBACK;
4188 return pp_seq();
4189}
4190
4191PP(pp_enterwhen)
4192{
4193 dVAR; dSP;
4194 register PERL_CONTEXT *cx;
4195 const I32 gimme = GIMME_V;
4196
4197 /* This is essentially an optimization: if the match
4198 fails, we don't want to push a context and then
4199 pop it again right away, so we skip straight
4200 to the op that follows the leavewhen.
4201 */
4202 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4203 return cLOGOP->op_other->op_next;
4204
4205 ENTER;
4206 SAVETMPS;
4207
4208 PUSHBLOCK(cx, CXt_WHEN, SP);
4209 PUSHWHEN(cx);
4210
4211 RETURN;
4212}
4213
4214PP(pp_leavewhen)
4215{
4216 dVAR; dSP;
4217 register PERL_CONTEXT *cx;
4218 I32 gimme;
4219 SV **newsp;
4220 PMOP *newpm;
4221
4222 POPBLOCK(cx,newpm);
4223 assert(CxTYPE(cx) == CXt_WHEN);
4224
4225 SP = newsp;
4226 PUTBACK;
4227
4228 PL_curpm = newpm; /* pop $1 et al */
4229
4230 LEAVE;
4231 return NORMAL;
4232}
4233
4234PP(pp_continue)
4235{
4236 dVAR;
4237 I32 cxix;
4238 register PERL_CONTEXT *cx;
4239 I32 inner;
4240
4241 cxix = dopoptowhen(cxstack_ix);
4242 if (cxix < 0)
4243 DIE(aTHX_ "Can't \"continue\" outside a when block");
4244 if (cxix < cxstack_ix)
4245 dounwind(cxix);
4246
4247 /* clear off anything above the scope we're re-entering */
4248 inner = PL_scopestack_ix;
4249 TOPBLOCK(cx);
4250 if (PL_scopestack_ix < inner)
4251 leave_scope(PL_scopestack[PL_scopestack_ix]);
4252 PL_curcop = cx->blk_oldcop;
4253 return cx->blk_givwhen.leave_op;
4254}
4255
4256PP(pp_break)
4257{
4258 dVAR;
4259 I32 cxix;
4260 register PERL_CONTEXT *cx;
4261 I32 inner;
4262
4263 cxix = dopoptogiven(cxstack_ix);
4264 if (cxix < 0) {
4265 if (PL_op->op_flags & OPf_SPECIAL)
4266 DIE(aTHX_ "Can't use when() outside a topicalizer");
4267 else
4268 DIE(aTHX_ "Can't \"break\" outside a given block");
4269 }
4270 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4271 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4272
4273 if (cxix < cxstack_ix)
4274 dounwind(cxix);
4275
4276 /* clear off anything above the scope we're re-entering */
4277 inner = PL_scopestack_ix;
4278 TOPBLOCK(cx);
4279 if (PL_scopestack_ix < inner)
4280 leave_scope(PL_scopestack[PL_scopestack_ix]);
4281 PL_curcop = cx->blk_oldcop;
4282
4283 if (CxFOREACH(cx))
022eaa24 4284 return CX_LOOP_NEXTOP_GET(cx);
0d863452
RH		 4285 else
4286 return cx->blk_givwhen.leave_op;
4287}
4288
a1b95068 4289STATIC OP *
cea2e8a9 4290S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 4291{
4292 STRLEN len;
4293 register char *s = SvPV_force(sv, len);
c445ea15
AL		 4294 register char * const send = s + len;
4295 register char *base = NULL;
a0d0e21e 4296 register I32 skipspaces = 0;
9c5ffd7c
JH		 4297 bool noblank = FALSE;
4298 bool repeat = FALSE;
a0d0e21e 4299 bool postspace = FALSE;
dea28490
JJ		 4300 U32 *fops;
4301 register U32 *fpc;
cbbf8932 4302 U32 *linepc = NULL;
a0d0e21e
LW		 4303 register I32 arg;
4304 bool ischop;
a1b95068
WL		 4305 bool unchopnum = FALSE;
4306 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
a0d0e21e 4307
55497cff 4308 if (len == 0)
cea2e8a9 4309 Perl_croak(aTHX_ "Null picture in formline");
ac27b0f5 4310
815f25c6
DM		 4311 /* estimate the buffer size needed */
4312 for (base = s; s <= send; s++) {
a1b95068 4313 if (*s == '\n' || *s == '@' || *s == '^')
815f25c6
DM		 4314 maxops += 10;
4315 }
4316 s = base;
c445ea15 4317 base = NULL;
815f25c6 4318
a02a5408 4319 Newx(fops, maxops, U32);
a0d0e21e
LW		 4320 fpc = fops;
4321
4322 if (s < send) {
4323 linepc = fpc;
4324 *fpc++ = FF_LINEMARK;
4325 noblank = repeat = FALSE;
4326 base = s;
4327 }
4328
4329 while (s <= send) {
4330 switch (*s++) {
4331 default:
4332 skipspaces = 0;
4333 continue;
4334
4335 case '~':
4336 if (*s == '~') {
4337 repeat = TRUE;
4338 *s = ' ';
4339 }
4340 noblank = TRUE;
4341 s[-1] = ' ';
4342 /* FALL THROUGH */
4343 case ' ': case '\t':
4344 skipspaces++;
4345 continue;
a1b95068
WL		 4346 case 0:
4347 if (s < send) {
4348 skipspaces = 0;
4349 continue;
4350 } /* else FALL THROUGH */
4351 case '\n':
a0d0e21e
LW		 4352 arg = s - base;
4353 skipspaces++;
4354 arg -= skipspaces;
4355 if (arg) {
5f05dabc 4356 if (postspace)
a0d0e21e 4357 *fpc++ = FF_SPACE;
a0d0e21e 4358 *fpc++ = FF_LITERAL;
eb160463 4359 *fpc++ = (U16)arg;
a0d0e21e 4360 }
5f05dabc 4361 postspace = FALSE;
a0d0e21e
LW		 4362 if (s <= send)
4363 skipspaces--;
4364 if (skipspaces) {
4365 *fpc++ = FF_SKIP;
eb160463 4366 *fpc++ = (U16)skipspaces;
a0d0e21e
LW		 4367 }
4368 skipspaces = 0;
4369 if (s <= send)
4370 *fpc++ = FF_NEWLINE;
4371 if (noblank) {
4372 *fpc++ = FF_BLANK;
4373 if (repeat)
4374 arg = fpc - linepc + 1;
4375 else
4376 arg = 0;
eb160463 4377 *fpc++ = (U16)arg;
a0d0e21e
LW		 4378 }
4379 if (s < send) {
4380 linepc = fpc;
4381 *fpc++ = FF_LINEMARK;
4382 noblank = repeat = FALSE;
4383 base = s;
4384 }
4385 else
4386 s++;
4387 continue;
4388
4389 case '@':
4390 case '^':
4391 ischop = s[-1] == '^';
4392
4393 if (postspace) {
4394 *fpc++ = FF_SPACE;
4395 postspace = FALSE;
4396 }
4397 arg = (s - base) - 1;
4398 if (arg) {
4399 *fpc++ = FF_LITERAL;
eb160463 4400 *fpc++ = (U16)arg;
a0d0e21e
LW		 4401 }
4402
4403 base = s - 1;
4404 *fpc++ = FF_FETCH;
4405 if (*s == '*') {
4406 s++;
a1b95068
WL		 4407 *fpc++ = 2; /* skip the @* or ^* */
4408 if (ischop) {
4409 *fpc++ = FF_LINESNGL;
4410 *fpc++ = FF_CHOP;
4411 } else
4412 *fpc++ = FF_LINEGLOB;
a0d0e21e
LW		 4413 }
4414 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4415 arg = ischop ? 512 : 0;
4416 base = s - 1;
4417 while (*s == '#')
4418 s++;
4419 if (*s == '.') {
06b5626a 4420 const char * const f = ++s;
a0d0e21e
LW		 4421 while (*s == '#')
4422 s++;
4423 arg |= 256 + (s - f);
4424 }
4425 *fpc++ = s - base; /* fieldsize for FETCH */
4426 *fpc++ = FF_DECIMAL;
eb160463 4427 *fpc++ = (U16)arg;
a1b95068 4428 unchopnum |= ! ischop;
784707d5
JP		 4429 }
4430 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4431 arg = ischop ? 512 : 0;
4432 base = s - 1;
4433 s++; /* skip the '0' first */
4434 while (*s == '#')
4435 s++;
4436 if (*s == '.') {
06b5626a 4437 const char * const f = ++s;
784707d5
JP		 4438 while (*s == '#')
4439 s++;
4440 arg |= 256 + (s - f);
4441 }
4442 *fpc++ = s - base; /* fieldsize for FETCH */
4443 *fpc++ = FF_0DECIMAL;
eb160463 4444 *fpc++ = (U16)arg;
a1b95068 4445 unchopnum |= ! ischop;
a0d0e21e
LW		 4446 }
4447 else {
4448 I32 prespace = 0;
4449 bool ismore = FALSE;
4450
4451 if (*s == '>') {
4452 while (*++s == '>') ;
4453 prespace = FF_SPACE;
4454 }
4455 else if (*s == '|') {
4456 while (*++s == '|') ;
4457 prespace = FF_HALFSPACE;
4458 postspace = TRUE;
4459 }
4460 else {
4461 if (*s == '<')
4462 while (*++s == '<') ;
4463 postspace = TRUE;
4464 }
4465 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4466 s += 3;
4467 ismore = TRUE;
4468 }
4469 *fpc++ = s - base; /* fieldsize for FETCH */
4470
4471 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4472
4473 if (prespace)
eb160463 4474 *fpc++ = (U16)prespace;
a0d0e21e
LW		 4475 *fpc++ = FF_ITEM;
4476 if (ismore)
4477 *fpc++ = FF_MORE;
4478 if (ischop)
4479 *fpc++ = FF_CHOP;
4480 }
4481 base = s;
4482 skipspaces = 0;
4483 continue;
4484 }
4485 }
4486 *fpc++ = FF_END;
4487
815f25c6 4488 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
a0d0e21e
LW		 4489 arg = fpc - fops;
4490 { /* need to jump to the next word */
4491 int z;
4492 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
dea28490 4493 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
a0d0e21e
LW		 4494 s = SvPVX(sv) + SvCUR(sv) + z;
4495 }
dea28490 4496 Copy(fops, s, arg, U32);
a0d0e21e 4497 Safefree(fops);
c445ea15 4498 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
a0d0e21e 4499 SvCOMPILED_on(sv);
a1b95068 4500
bfed75c6 4501 if (unchopnum && repeat)
a1b95068
WL		 4502 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4503 return 0;
4504}
4505
4506
4507STATIC bool
4508S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4509{
4510 /* Can value be printed in fldsize chars, using %*.*f ? */
4511 NV pwr = 1;
4512 NV eps = 0.5;
4513 bool res = FALSE;
4514 int intsize = fldsize - (value < 0 ? 1 : 0);
4515
4516 if (frcsize & 256)
4517 intsize--;
4518 frcsize &= 255;
4519 intsize -= frcsize;
4520
4521 while (intsize--) pwr *= 10.0;
4522 while (frcsize--) eps /= 10.0;
4523
4524 if( value >= 0 ){
4525 if (value + eps >= pwr)
4526 res = TRUE;
4527 } else {
4528 if (value - eps <= -pwr)
4529 res = TRUE;
4530 }
4531 return res;
a0d0e21e 4532}
4e35701f 4533
bbed91b5 4534static I32
0bd48802 4535S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
bbed91b5 4536{
27da23d5 4537 dVAR;
0bd48802 4538 SV * const datasv = FILTER_DATA(idx);
504618e9 4539 const int filter_has_file = IoLINES(datasv);
0bd48802
AL		 4540 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4541 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
941a98a0 4542 int status = 0;
ec0b63d7 4543 SV *upstream;
941a98a0 4544 STRLEN got_len;
95b63a38 4545 const char *got_p = NULL;
941a98a0 4546 const char *prune_from = NULL;
34113e50 4547 bool read_from_cache = FALSE;
bb7a0f54
MHM		 4548 STRLEN umaxlen;
4549
4550 assert(maxlen >= 0);
4551 umaxlen = maxlen;
5675696b 4552
bbed91b5
KF		 4553 /* I was having segfault trouble under Linux 2.2.5 after a
4554 parse error occured. (Had to hack around it with a test
13765c85 4555 for PL_parser->error_count == 0.) Solaris doesn't segfault --
bbed91b5
KF		 4556 not sure where the trouble is yet. XXX */
4557
941a98a0 4558 if (IoFMT_GV(datasv)) {
937b367d
NC		 4559 SV *const cache = (SV *)IoFMT_GV(datasv);
4560 if (SvOK(cache)) {
4561 STRLEN cache_len;
4562 const char *cache_p = SvPV(cache, cache_len);
941a98a0
NC		 4563 STRLEN take = 0;
4564
bb7a0f54 4565 if (umaxlen) {
941a98a0
NC		 4566 /* Running in block mode and we have some cached data already.
4567 */
bb7a0f54 4568 if (cache_len >= umaxlen) {
941a98a0
NC		 4569 /* In fact, so much data we don't even need to call
4570 filter_read. */
bb7a0f54 4571 take = umaxlen;
941a98a0
NC		 4572 }
4573 } else {
10edeb5d
JH		 4574 const char *const first_nl =
4575 (const char *)memchr(cache_p, '\n', cache_len);
941a98a0
NC		 4576 if (first_nl) {
4577 take = first_nl + 1 - cache_p;
4578 }
4579 }
4580 if (take) {
4581 sv_catpvn(buf_sv, cache_p, take);
4582 sv_chop(cache, cache_p + take);
937b367d
NC		 4583 /* Definately not EOF */
4584 return 1;
4585 }
941a98a0 4586
937b367d 4587 sv_catsv(buf_sv, cache);
bb7a0f54
MHM		 4588 if (umaxlen) {
4589 umaxlen -= cache_len;
941a98a0 4590 }
937b367d 4591 SvOK_off(cache);
34113e50 4592 read_from_cache = TRUE;
937b367d
NC		 4593 }
4594 }
ec0b63d7 4595
34113e50
NC		 4596 /* Filter API says that the filter appends to the contents of the buffer.
4597 Usually the buffer is "", so the details don't matter. But if it's not,
4598 then clearly what it contains is already filtered by this filter, so we
4599 don't want to pass it in a second time.
4600 I'm going to use a mortal in case the upstream filter croaks. */
ec0b63d7
NC		 4601 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4602 ? sv_newmortal() : buf_sv;
4603 SvUPGRADE(upstream, SVt_PV);
937b367d 4604
bbed91b5 4605 if (filter_has_file) {
67e70b33 4606 status = FILTER_READ(idx+1, upstream, 0);
bbed91b5
KF		 4607 }
4608
34113e50 4609 if (filter_sub && status >= 0) {
39644a26 4610 dSP;
bbed91b5
KF		 4611 int count;
4612
4613 ENTER;
4614 SAVE_DEFSV;
4615 SAVETMPS;
4616 EXTEND(SP, 2);
4617
5675696b 4618 DEFSV = upstream;
bbed91b5 4619 PUSHMARK(SP);
67e70b33 4620 PUSHs(sv_2mortal(newSViv(0)));
bbed91b5
KF		 4621 if (filter_state) {
4622 PUSHs(filter_state);
4623 }
4624 PUTBACK;
4625 count = call_sv(filter_sub, G_SCALAR);
4626 SPAGAIN;
4627
4628 if (count > 0) {
4629 SV *out = POPs;
4630 if (SvOK(out)) {
941a98a0 4631 status = SvIV(out);
bbed91b5
KF		 4632 }
4633 }
4634
4635 PUTBACK;
4636 FREETMPS;
4637 LEAVE;
4638 }
4639
941a98a0
NC		 4640 if(SvOK(upstream)) {
4641 got_p = SvPV(upstream, got_len);
bb7a0f54
MHM		 4642 if (umaxlen) {
4643 if (got_len > umaxlen) {
4644 prune_from = got_p + umaxlen;
937b367d 4645 }
941a98a0 4646 } else {
10edeb5d
JH		 4647 const char *const first_nl =
4648 (const char *)memchr(got_p, '\n', got_len);
941a98a0
NC		 4649 if (first_nl && first_nl + 1 < got_p + got_len) {
4650 /* There's a second line here... */
4651 prune_from = first_nl + 1;
937b367d 4652 }
937b367d
NC		 4653 }
4654 }
941a98a0
NC		 4655 if (prune_from) {
4656 /* Oh. Too long. Stuff some in our cache. */
4657 STRLEN cached_len = got_p + got_len - prune_from;
4658 SV *cache = (SV *)IoFMT_GV(datasv);
4659
4660 if (!cache) {
bb7a0f54 4661 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
941a98a0
NC		 4662 } else if (SvOK(cache)) {
4663 /* Cache should be empty. */
4664 assert(!SvCUR(cache));
4665 }
4666
4667 sv_setpvn(cache, prune_from, cached_len);
4668 /* If you ask for block mode, you may well split UTF-8 characters.
4669 "If it breaks, you get to keep both parts"
4670 (Your code is broken if you don't put them back together again
4671 before something notices.) */
4672 if (SvUTF8(upstream)) {
4673 SvUTF8_on(cache);
4674 }
4675 SvCUR_set(upstream, got_len - cached_len);
4676 /* Can't yet be EOF */
4677 if (status == 0)
4678 status = 1;
4679 }
937b367d 4680
34113e50
NC		 4681 /* If they are at EOF but buf_sv has something in it, then they may never
4682 have touched the SV upstream, so it may be undefined. If we naively
4683 concatenate it then we get a warning about use of uninitialised value.
4684 */
4685 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
937b367d
NC		 4686 sv_catsv(buf_sv, upstream);
4687 }
4688
941a98a0 4689 if (status <= 0) {
bbed91b5 4690 IoLINES(datasv) = 0;
937b367d 4691 SvREFCNT_dec(IoFMT_GV(datasv));
bbed91b5
KF		 4692 if (filter_state) {
4693 SvREFCNT_dec(filter_state);
a0714e2c 4694 IoTOP_GV(datasv) = NULL;
bbed91b5
KF		 4695 }
4696 if (filter_sub) {
4697 SvREFCNT_dec(filter_sub);
a0714e2c 4698 IoBOTTOM_GV(datasv) = NULL;
bbed91b5 4699 }
0bd48802 4700 filter_del(S_run_user_filter);
bbed91b5 4701 }
34113e50
NC		 4702 if (status == 0 && read_from_cache) {
4703 /* If we read some data from the cache (and by getting here it implies
4704 that we emptied the cache) then we aren't yet at EOF, and mustn't
4705 report that to our caller. */
4706 return 1;
4707 }
941a98a0 4708 return status;
bbed91b5 4709}
84d4ea48 4710
be4b629d
CN		 4711/* perhaps someone can come up with a better name for
4712 this? it is not really "absolute", per se ... */
cf42f822 4713static bool
5f66b61c 4714S_path_is_absolute(const char *name)
be4b629d
CN		 4715{
4716 if (PERL_FILE_IS_ABSOLUTE(name)
4717#ifdef MACOS_TRADITIONAL
0bd48802 4718 || (*name == ':')
be4b629d
CN		 4719#else
4720 || (*name == '.' && (name[1] == '/' ||
0bd48802 4721 (name[1] == '.' && name[2] == '/')))
be4b629d 4722#endif
0bd48802 4723 )
be4b629d
CN		 4724 {
4725 return TRUE;
4726 }
4727 else
4728 return FALSE;
4729}
241d1a3b
NC		 4730
4731/*
4732 * Local variables:
4733 * c-indentation-style: bsd
4734 * c-basic-offset: 4
4735 * indent-tabs-mode: t
4736 * End:
4737 *
37442d52
RGS		 4738 * ex: set ts=8 sts=4 sw=4 noet:
4739 */
Unnamed repository; edit this file 'description' to name the repository.