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