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