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
Remove widesyscalls and numeric_compat1, two unused per-interpreter
[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
NC		 127 STRLEN len;
128 const char *t = 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
1e2e3d02 153 if (eng)
c737faaf 154 PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm_flags));
1e2e3d02 155 else
c737faaf
YO		 156 PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm_flags));
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));
5a844595
GS		 1462 ++PL_error_count;
1463}
1464
a0d0e21e 1465OP *
35a4481c 1466Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1467{
27da23d5 1468 dVAR;
87582a92 1469
3280af22 1470 if (PL_in_eval) {
a0d0e21e 1471 I32 cxix;
a0d0e21e 1472 I32 gimme;
a0d0e21e 1473
4e6ea2c3 1474 if (message) {
faef0170 1475 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1476 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1477 SV * const err = ERRSV;
c445ea15 1478 const char *e = NULL;
98eae8f5 1479 if (!SvPOK(err))
c69006e4 1480 sv_setpvn(err,"",0);
98eae8f5 1481 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1482 STRLEN len;
349d4f2f 1483 e = SvPV_const(err, len);
0510663f 1484 e += len - msglen;
98eae8f5 1485 if (*e != *message || strNE(e,message))
c445ea15 1486 e = NULL;
98eae8f5
GS		 1487 }
1488 if (!e) {
1489 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1490 sv_catpvn(err, prefix, sizeof(prefix)-1);
1491 sv_catpvn(err, message, msglen);
e476b1b5 1492 if (ckWARN(WARN_MISC)) {
504618e9 1493 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1494 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1495 }
4633a7c4 1496 }
4633a7c4 1497 }
1aa99e6b 1498 else {
06bf62c7 1499 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1500 }
4633a7c4 1501 }
4e6ea2c3 1502
5a844595
GS		 1503 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1504 && PL_curstackinfo->si_prev)
1505 {
bac4b2ad 1506 dounwind(-1);
d3acc0f7 1507 POPSTACK;
bac4b2ad 1508 }
e336de0d 1509
a0d0e21e
LW		 1510 if (cxix >= 0) {
1511 I32 optype;
35a4481c 1512 register PERL_CONTEXT *cx;
901017d6 1513 SV **newsp;
a0d0e21e
LW		 1514
1515 if (cxix < cxstack_ix)
1516 dounwind(cxix);
1517
3280af22 1518 POPBLOCK(cx,PL_curpm);
6b35e009 1519 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1520 if (!message)
349d4f2f 1521 message = SvPVx_const(ERRSV, msglen);
10edeb5d 1522 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
bf49b057 1523 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1524 my_exit(1);
1525 }
1526 POPEVAL(cx);
1527
1528 if (gimme == G_SCALAR)
3280af22
NIS		 1529 *++newsp = &PL_sv_undef;
1530 PL_stack_sp = newsp;
a0d0e21e
LW		 1531
1532 LEAVE;
748a9306 1533
7fb6a879
GS		 1534 /* LEAVE could clobber PL_curcop (see save_re_context())
1535 * XXX it might be better to find a way to avoid messing with
1536 * PL_curcop in save_re_context() instead, but this is a more
1537 * minimal fix --GSAR */
1538 PL_curcop = cx->blk_oldcop;
1539
7a2e2cd6 1540 if (optype == OP_REQUIRE) {
44f8325f 1541 const char* const msg = SvPVx_nolen_const(ERRSV);
901017d6 1542 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1543 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1544 &PL_sv_undef, 0);
5a844595
GS		 1545 DIE(aTHX_ "%sCompilation failed in require",
1546 *msg ? msg : "Unknown error\n");
7a2e2cd6 1547 }
f39bc417
DM		 1548 assert(CxTYPE(cx) == CXt_EVAL);
1549 return cx->blk_eval.retop;
a0d0e21e
LW		 1550 }
1551 }
9cc2fdd3 1552 if (!message)
349d4f2f 1553 message = SvPVx_const(ERRSV, msglen);
87582a92 1554
7ff03255 1555 write_to_stderr(message, msglen);
f86702cc 1556 my_failure_exit();
1557 /* NOTREACHED */
a0d0e21e
LW		 1558 return 0;
1559}
1560
1561PP(pp_xor)
1562{
97aff369 1563 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW		 1564 if (SvTRUE(left) != SvTRUE(right))
1565 RETSETYES;
1566 else
1567 RETSETNO;
1568}
1569
a0d0e21e
LW		 1570PP(pp_caller)
1571{
97aff369 1572 dVAR;
39644a26 1573 dSP;
a0d0e21e 1574 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1575 register const PERL_CONTEXT *cx;
1576 register const PERL_CONTEXT *ccstack = cxstack;
1577 const PERL_SI *top_si = PL_curstackinfo;
54310121 1578 I32 gimme;
06b5626a 1579 const char *stashname;
a0d0e21e
LW		 1580 I32 count = 0;
1581
1582 if (MAXARG)
1583 count = POPi;
27d41816 1584
a0d0e21e 1585 for (;;) {
2c375eb9
GS		 1586 /* we may be in a higher stacklevel, so dig down deeper */
1587 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1588 top_si = top_si->si_prev;
1589 ccstack = top_si->si_cxstack;
1590 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1591 }
a0d0e21e 1592 if (cxix < 0) {
27d41816
DM		 1593 if (GIMME != G_ARRAY) {
1594 EXTEND(SP, 1);
a0d0e21e 1595 RETPUSHUNDEF;
27d41816 1596 }
a0d0e21e
LW		 1597 RETURN;
1598 }
f2a7f298
DG		 1599 /* caller() should not report the automatic calls to &DB::sub */
1600 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1601 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1602 count++;
1603 if (!count--)
1604 break;
2c375eb9 1605 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1606 }
2c375eb9
GS		 1607
1608 cx = &ccstack[cxix];
7766f137 1609 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1610 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1611 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1612 field below is defined for any cx. */
f2a7f298
DG		 1613 /* caller() should not report the automatic calls to &DB::sub */
1614 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1615 cx = &ccstack[dbcxix];
06a5b730 1616 }
1617
ed094faf 1618 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1619 if (GIMME != G_ARRAY) {
27d41816 1620 EXTEND(SP, 1);
ed094faf 1621 if (!stashname)
3280af22 1622 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1623 else {
1624 dTARGET;
ed094faf 1625 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1626 PUSHs(TARG);
1627 }
a0d0e21e
LW		 1628 RETURN;
1629 }
a0d0e21e 1630
b3ca2e83 1631 EXTEND(SP, 11);
27d41816 1632
ed094faf 1633 if (!stashname)
3280af22 1634 PUSHs(&PL_sv_undef);
49d8d3a1 1635 else
ed094faf 1636 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1637 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1638 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1639 if (!MAXARG)
1640 RETURN;
7766f137 1641 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1642 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1643 /* So is ccstack[dbcxix]. */
07b8c804 1644 if (isGV(cvgv)) {
561b68a9 1645 SV * const sv = newSV(0);
c445ea15 1646 gv_efullname3(sv, cvgv, NULL);
07b8c804 1647 PUSHs(sv_2mortal(sv));
cc8d50a7 1648 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804
RGS		 1649 }
1650 else {
396482e1 1651 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
cc8d50a7 1652 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1653 }
a0d0e21e
LW		 1654 }
1655 else {
396482e1 1656 PUSHs(sv_2mortal(newSVpvs("(eval)")));
a0d0e21e
LW		 1657 PUSHs(sv_2mortal(newSViv(0)));
1658 }
54310121 1659 gimme = (I32)cx->blk_gimme;
1660 if (gimme == G_VOID)
3280af22 1661 PUSHs(&PL_sv_undef);
54310121 1662 else
1663 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1664 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1665 /* eval STRING */
06a5b730 1666 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1667 PUSHs(cx->blk_eval.cur_text);
3280af22 1668 PUSHs(&PL_sv_no);
0f79a09d 1669 }
811a4de9 1670 /* require */
0f79a09d
GS		 1671 else if (cx->blk_eval.old_namesv) {
1672 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1673 PUSHs(&PL_sv_yes);
06a5b730 1674 }
811a4de9
GS		 1675 /* eval BLOCK (try blocks have old_namesv == 0) */
1676 else {
1677 PUSHs(&PL_sv_undef);
1678 PUSHs(&PL_sv_undef);
1679 }
4633a7c4 1680 }
a682de96
GS		 1681 else {
1682 PUSHs(&PL_sv_undef);
1683 PUSHs(&PL_sv_undef);
1684 }
cc8d50a7 1685 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1686 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1687 {
66a1b24b
AL		 1688 AV * const ary = cx->blk_sub.argarray;
1689 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1690
3280af22 1691 if (!PL_dbargs) {
71315bf2 1692 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
0bd48802 1693 PL_dbargs = GvAV(gv_AVadd(tmpgv));
a5f75d66 1694 GvMULTI_on(tmpgv);
3ddcf04c 1695 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW		 1696 }
1697
3280af22
NIS		 1698 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1699 av_extend(PL_dbargs, AvFILLp(ary) + off);
1700 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1701 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1702 }
f3aa04c2
GS		 1703 /* XXX only hints propagated via op_private are currently
1704 * visible (others are not easily accessible, since they
1705 * use the global PL_hints) */
623e6609 1706 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
e476b1b5
GS		 1707 {
1708 SV * mask ;
72dc9ed5 1709 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1710
ac27b0f5 1711 if (old_warnings == pWARN_NONE ||
114bafba 1712 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1713 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1714 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1715 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1716 /* Get the bit mask for $warnings::Bits{all}, because
1717 * it could have been extended by warnings::register */
1718 SV **bits_all;
0bd48802 1719 HV * const bits = get_hv("warnings::Bits", FALSE);
017a3ce5 1720 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS		 1721 mask = newSVsv(*bits_all);
1722 }
1723 else {
1724 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1725 }
1726 }
e476b1b5 1727 else
72dc9ed5 1728 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
e476b1b5
GS		 1729 PUSHs(sv_2mortal(mask));
1730 }
b3ca2e83 1731
c28fe1ec 1732 PUSHs(cx->blk_oldcop->cop_hints_hash ?
b3ca2e83 1733 sv_2mortal(newRV_noinc(
c28fe1ec
NC		 1734 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1735 cx->blk_oldcop->cop_hints_hash)))
b3ca2e83 1736 : &PL_sv_undef);
a0d0e21e
LW		 1737 RETURN;
1738}
1739
a0d0e21e
LW		 1740PP(pp_reset)
1741{
97aff369 1742 dVAR;
39644a26 1743 dSP;
10edeb5d 1744 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
11faa288 1745 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1746 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1747 RETURN;
1748}
1749
dd2155a4
DM		 1750/* like pp_nextstate, but used instead when the debugger is active */
1751
a0d0e21e
LW		 1752PP(pp_dbstate)
1753{
27da23d5 1754 dVAR;
533c011a 1755 PL_curcop = (COP*)PL_op;
a0d0e21e 1756 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1757 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1758 FREETMPS;
1759
5df8de69
DM		 1760 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1761 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1762 {
39644a26 1763 dSP;
c09156bb 1764 register PERL_CONTEXT *cx;
f54cb97a 1765 const I32 gimme = G_ARRAY;
eb160463 1766 U8 hasargs;
0bd48802
AL		 1767 GV * const gv = PL_DBgv;
1768 register CV * const cv = GvCV(gv);
a0d0e21e 1769
a0d0e21e 1770 if (!cv)
cea2e8a9 1771 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1772
aea4f609
DM		 1773 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1774 /* don't do recursive DB::DB call */
a0d0e21e 1775 return NORMAL;
748a9306 1776
4633a7c4
LW		 1777 ENTER;
1778 SAVETMPS;
1779
3280af22 1780 SAVEI32(PL_debug);
55497cff 1781 SAVESTACK_POS();
3280af22 1782 PL_debug = 0;
748a9306 1783 hasargs = 0;
924508f0 1784 SPAGAIN;
748a9306 1785
aed2304a 1786 if (CvISXSUB(cv)) {
c127bd3a
SF		 1787 CvDEPTH(cv)++;
1788 PUSHMARK(SP);
1789 (void)(*CvXSUB(cv))(aTHX_ cv);
1790 CvDEPTH(cv)--;
1791 FREETMPS;
1792 LEAVE;
1793 return NORMAL;
1794 }
1795 else {
1796 PUSHBLOCK(cx, CXt_SUB, SP);
1797 PUSHSUB_DB(cx);
1798 cx->blk_sub.retop = PL_op->op_next;
1799 CvDEPTH(cv)++;
1800 SAVECOMPPAD();
1801 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1802 RETURNOP(CvSTART(cv));
1803 }
a0d0e21e
LW		 1804 }
1805 else
1806 return NORMAL;
1807}
1808
a0d0e21e
LW		 1809PP(pp_enteriter)
1810{
27da23d5 1811 dVAR; dSP; dMARK;
c09156bb 1812 register PERL_CONTEXT *cx;
f54cb97a 1813 const I32 gimme = GIMME_V;
a0d0e21e 1814 SV **svp;
df43650b 1815 U16 cxtype = CXt_LOOP | CXp_FOREACH;
7766f137
GS		 1816#ifdef USE_ITHREADS
1817 void *iterdata;
1818#endif
a0d0e21e 1819
4633a7c4
LW		 1820 ENTER;
1821 SAVETMPS;
1822
533c011a 1823 if (PL_op->op_targ) {
14f338dc
DM		 1824 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1825 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1826 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1827 SVs_PADSTALE, SVs_PADSTALE);
1828 }
c3564e5c 1829#ifndef USE_ITHREADS
dd2155a4 1830 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1831 SAVESPTR(*svp);
c3564e5c
GS		 1832#else
1833 SAVEPADSV(PL_op->op_targ);
cbfa9890 1834 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1835 cxtype |= CXp_PADVAR;
1836#endif
54b9620d
MB		 1837 }
1838 else {
0bd48802 1839 GV * const gv = (GV*)POPs;
7766f137 1840 svp = &GvSV(gv); /* symbol table variable */
0214ae40 1841 SAVEGENERICSV(*svp);
561b68a9 1842 *svp = newSV(0);
7766f137
GS		 1843#ifdef USE_ITHREADS
1844 iterdata = (void*)gv;
1845#endif
54b9620d 1846 }
4633a7c4 1847
0d863452
RH		 1848 if (PL_op->op_private & OPpITER_DEF)
1849 cxtype |= CXp_FOR_DEF;
1850
a0d0e21e
LW		 1851 ENTER;
1852
7766f137
GS		 1853 PUSHBLOCK(cx, cxtype, SP);
1854#ifdef USE_ITHREADS
1855 PUSHLOOP(cx, iterdata, MARK);
1856#else
a0d0e21e 1857 PUSHLOOP(cx, svp, MARK);
7766f137 1858#endif
533c011a 1859 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1860 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1861 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1862 dPOPss;
0bd48802 1863 SV * const right = (SV*)cx->blk_loop.iterary;
984a4bea
RD		 1864 SvGETMAGIC(sv);
1865 SvGETMAGIC(right);
4fe3f0fa
MHM		 1866 if (RANGE_IS_NUMERIC(sv,right)) {
1867 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1868 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1869 DIE(aTHX_ "Range iterator outside integer range");
1870 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1871 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM		 1872#ifdef DEBUGGING
1873 /* for correct -Dstv display */
1874 cx->blk_oldsp = sp - PL_stack_base;
1875#endif
89ea2908 1876 }
3f63a782 1877 else {
89ea2908 1878 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1879 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1880 (void) SvPV_nolen_const(right);
3f63a782 1881 }
89ea2908 1882 }
ef3e5ea9 1883 else if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1884 cx->blk_loop.itermax = 0;
1885 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
ef3e5ea9
NC		 1886
1887 }
89ea2908 1888 }
4633a7c4 1889 else {
3280af22
NIS		 1890 cx->blk_loop.iterary = PL_curstack;
1891 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9 1892 if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1893 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1894 cx->blk_loop.iterix = cx->blk_oldsp + 1;
ef3e5ea9
NC		 1895 }
1896 else {
1897 cx->blk_loop.iterix = MARK - PL_stack_base;
1898 }
4633a7c4 1899 }
a0d0e21e
LW		 1900
1901 RETURN;
1902}
1903
1904PP(pp_enterloop)
1905{
27da23d5 1906 dVAR; dSP;
c09156bb 1907 register PERL_CONTEXT *cx;
f54cb97a 1908 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1909
1910 ENTER;
1911 SAVETMPS;
1912 ENTER;
1913
1914 PUSHBLOCK(cx, CXt_LOOP, SP);
1915 PUSHLOOP(cx, 0, SP);
1916
1917 RETURN;
1918}
1919
1920PP(pp_leaveloop)
1921{
27da23d5 1922 dVAR; dSP;
c09156bb 1923 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1924 I32 gimme;
1925 SV **newsp;
1926 PMOP *newpm;
1927 SV **mark;
1928
1929 POPBLOCK(cx,newpm);
3a1b2b9e 1930 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1931 mark = newsp;
a8bba7fa 1932 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1933
a1f49e72 1934 TAINT_NOT;
54310121 1935 if (gimme == G_VOID)
6f207bd3 1936 NOOP;
54310121 1937 else if (gimme == G_SCALAR) {
1938 if (mark < SP)
1939 *++newsp = sv_mortalcopy(*SP);
1940 else
3280af22 1941 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1942 }
1943 else {
a1f49e72 1944 while (mark < SP) {
a0d0e21e 1945 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1946 TAINT_NOT; /* Each item is independent */
1947 }
a0d0e21e 1948 }
f86702cc 1949 SP = newsp;
1950 PUTBACK;
1951
a8bba7fa 1952 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1953 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1954
a0d0e21e
LW		 1955 LEAVE;
1956 LEAVE;
1957
f86702cc 1958 return NORMAL;
a0d0e21e
LW		 1959}
1960
1961PP(pp_return)
1962{
27da23d5 1963 dVAR; dSP; dMARK;
c09156bb 1964 register PERL_CONTEXT *cx;
f86702cc 1965 bool popsub2 = FALSE;
b45de488 1966 bool clear_errsv = FALSE;
a0d0e21e
LW		 1967 I32 gimme;
1968 SV **newsp;
1969 PMOP *newpm;
1970 I32 optype = 0;
b0d9ce38 1971 SV *sv;
f39bc417 1972 OP *retop;
a0d0e21e 1973
0bd48802
AL		 1974 const I32 cxix = dopoptosub(cxstack_ix);
1975
9850bf21
RH		 1976 if (cxix < 0) {
1977 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1978 * sort block, which is a CXt_NULL
1979 * not a CXt_SUB */
1980 dounwind(0);
d7507f74
RH		 1981 PL_stack_base[1] = *PL_stack_sp;
1982 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1983 return 0;
1984 }
9850bf21
RH		 1985 else
1986 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 1987 }
a0d0e21e
LW		 1988 if (cxix < cxstack_ix)
1989 dounwind(cxix);
1990
d7507f74
RH		 1991 if (CxMULTICALL(&cxstack[cxix])) {
1992 gimme = cxstack[cxix].blk_gimme;
1993 if (gimme == G_VOID)
1994 PL_stack_sp = PL_stack_base;
1995 else if (gimme == G_SCALAR) {
1996 PL_stack_base[1] = *PL_stack_sp;
1997 PL_stack_sp = PL_stack_base + 1;
1998 }
9850bf21 1999 return 0;
d7507f74 2000 }
9850bf21 2001
a0d0e21e 2002 POPBLOCK(cx,newpm);
6b35e009 2003 switch (CxTYPE(cx)) {
a0d0e21e 2004 case CXt_SUB:
f86702cc 2005 popsub2 = TRUE;
f39bc417 2006 retop = cx->blk_sub.retop;
5dd42e15 2007 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 2008 break;
2009 case CXt_EVAL:
b45de488
GS		 2010 if (!(PL_in_eval & EVAL_KEEPERR))
2011 clear_errsv = TRUE;
a0d0e21e 2012 POPEVAL(cx);
f39bc417 2013 retop = cx->blk_eval.retop;
1d76a5c3
GS		 2014 if (CxTRYBLOCK(cx))
2015 break;
067f92a0 2016 lex_end();
748a9306
LW		 2017 if (optype == OP_REQUIRE &&
2018 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2019 {
54310121 2020 /* Unassume the success we assumed earlier. */
901017d6 2021 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 2022 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
be2597df 2023 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
748a9306 2024 }
a0d0e21e 2025 break;
7766f137
GS		 2026 case CXt_FORMAT:
2027 POPFORMAT(cx);
f39bc417 2028 retop = cx->blk_sub.retop;
7766f137 2029 break;
a0d0e21e 2030 default:
cea2e8a9 2031 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 2032 }
2033
a1f49e72 2034 TAINT_NOT;
a0d0e21e 2035 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2036 if (MARK < SP) {
2037 if (popsub2) {
a8bba7fa 2038 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 2039 if (SvTEMP(TOPs)) {
2040 *++newsp = SvREFCNT_inc(*SP);
2041 FREETMPS;
2042 sv_2mortal(*newsp);
959e3673
GS		 2043 }
2044 else {
2045 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2046 FREETMPS;
959e3673
GS		 2047 *++newsp = sv_mortalcopy(sv);
2048 SvREFCNT_dec(sv);
a29cdaf0 2049 }
959e3673
GS		 2050 }
2051 else
a29cdaf0 2052 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2053 }
2054 else
a29cdaf0 2055 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2056 }
2057 else
3280af22 2058 *++newsp = &PL_sv_undef;
a0d0e21e 2059 }
54310121 2060 else if (gimme == G_ARRAY) {
a1f49e72 2061 while (++MARK <= SP) {
f86702cc 2062 *++newsp = (popsub2 && SvTEMP(*MARK))
2063 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2064 TAINT_NOT; /* Each item is independent */
2065 }
a0d0e21e 2066 }
3280af22 2067 PL_stack_sp = newsp;
a0d0e21e 2068
5dd42e15 2069 LEAVE;
f86702cc 2070 /* Stack values are safe: */
2071 if (popsub2) {
5dd42e15 2072 cxstack_ix--;
b0d9ce38 2073 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2074 }
b0d9ce38 2075 else
c445ea15 2076 sv = NULL;
3280af22 2077 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2078
b0d9ce38 2079 LEAVESUB(sv);
b45de488 2080 if (clear_errsv)
c69006e4 2081 sv_setpvn(ERRSV,"",0);
f39bc417 2082 return retop;
a0d0e21e
LW		 2083}
2084
2085PP(pp_last)
2086{
27da23d5 2087 dVAR; dSP;
a0d0e21e 2088 I32 cxix;
c09156bb 2089 register PERL_CONTEXT *cx;
f86702cc 2090 I32 pop2 = 0;
a0d0e21e 2091 I32 gimme;
8772537c 2092 I32 optype;
a0d0e21e
LW		 2093 OP *nextop;
2094 SV **newsp;
2095 PMOP *newpm;
a8bba7fa 2096 SV **mark;
c445ea15 2097 SV *sv = NULL;
9d4ba2ae 2098
a0d0e21e 2099
533c011a 2100 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2101 cxix = dopoptoloop(cxstack_ix);
2102 if (cxix < 0)
a651a37d 2103 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2104 }
2105 else {
2106 cxix = dopoptolabel(cPVOP->op_pv);
2107 if (cxix < 0)
cea2e8a9 2108 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2109 }
2110 if (cxix < cxstack_ix)
2111 dounwind(cxix);
2112
2113 POPBLOCK(cx,newpm);
5dd42e15 2114 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2115 mark = newsp;
6b35e009 2116 switch (CxTYPE(cx)) {
a0d0e21e 2117 case CXt_LOOP:
f86702cc 2118 pop2 = CXt_LOOP;
a8bba7fa 2119 newsp = PL_stack_base + cx->blk_loop.resetsp;
022eaa24 2120 nextop = cx->blk_loop.my_op->op_lastop->op_next;
a0d0e21e 2121 break;
f86702cc 2122 case CXt_SUB:
f86702cc 2123 pop2 = CXt_SUB;
f39bc417 2124 nextop = cx->blk_sub.retop;
a0d0e21e 2125 break;
f86702cc 2126 case CXt_EVAL:
2127 POPEVAL(cx);
f39bc417 2128 nextop = cx->blk_eval.retop;
a0d0e21e 2129 break;
7766f137
GS		 2130 case CXt_FORMAT:
2131 POPFORMAT(cx);
f39bc417 2132 nextop = cx->blk_sub.retop;
7766f137 2133 break;
a0d0e21e 2134 default:
cea2e8a9 2135 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2136 }
2137
a1f49e72 2138 TAINT_NOT;
a0d0e21e 2139 if (gimme == G_SCALAR) {
f86702cc 2140 if (MARK < SP)
2141 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2142 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2143 else
3280af22 2144 *++newsp = &PL_sv_undef;
a0d0e21e 2145 }
54310121 2146 else if (gimme == G_ARRAY) {
a1f49e72 2147 while (++MARK <= SP) {
f86702cc 2148 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2149 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2150 TAINT_NOT; /* Each item is independent */
2151 }
f86702cc 2152 }
2153 SP = newsp;
2154 PUTBACK;
2155
5dd42e15
DM		 2156 LEAVE;
2157 cxstack_ix--;
f86702cc 2158 /* Stack values are safe: */
2159 switch (pop2) {
2160 case CXt_LOOP:
a8bba7fa 2161 POPLOOP(cx); /* release loop vars ... */
4fdae800 2162 LEAVE;
f86702cc 2163 break;
2164 case CXt_SUB:
b0d9ce38 2165 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2166 break;
a0d0e21e 2167 }
3280af22 2168 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2169
b0d9ce38 2170 LEAVESUB(sv);
9d4ba2ae
AL		 2171 PERL_UNUSED_VAR(optype);
2172 PERL_UNUSED_VAR(gimme);
f86702cc 2173 return nextop;
a0d0e21e
LW		 2174}
2175
2176PP(pp_next)
2177{
27da23d5 2178 dVAR;
a0d0e21e 2179 I32 cxix;
c09156bb 2180 register PERL_CONTEXT *cx;
85538317 2181 I32 inner;
a0d0e21e 2182
533c011a 2183 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2184 cxix = dopoptoloop(cxstack_ix);
2185 if (cxix < 0)
a651a37d 2186 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2187 }
2188 else {
2189 cxix = dopoptolabel(cPVOP->op_pv);
2190 if (cxix < 0)
cea2e8a9 2191 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2192 }
2193 if (cxix < cxstack_ix)
2194 dounwind(cxix);
2195
85538317
GS		 2196 /* clear off anything above the scope we're re-entering, but
2197 * save the rest until after a possible continue block */
2198 inner = PL_scopestack_ix;
1ba6ee2b 2199 TOPBLOCK(cx);
85538317
GS		 2200 if (PL_scopestack_ix < inner)
2201 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2202 PL_curcop = cx->blk_oldcop;
022eaa24 2203 return CX_LOOP_NEXTOP_GET(cx);
a0d0e21e
LW		 2204}
2205
2206PP(pp_redo)
2207{
27da23d5 2208 dVAR;
a0d0e21e 2209 I32 cxix;
c09156bb 2210 register PERL_CONTEXT *cx;
a0d0e21e 2211 I32 oldsave;
a034e688 2212 OP* redo_op;
a0d0e21e 2213
533c011a 2214 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2215 cxix = dopoptoloop(cxstack_ix);
2216 if (cxix < 0)
a651a37d 2217 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2218 }
2219 else {
2220 cxix = dopoptolabel(cPVOP->op_pv);
2221 if (cxix < 0)
cea2e8a9 2222 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2223 }
2224 if (cxix < cxstack_ix)
2225 dounwind(cxix);
2226
022eaa24 2227 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
a034e688
DM		 2228 if (redo_op->op_type == OP_ENTER) {
2229 /* pop one less context to avoid $x being freed in while (my $x..) */
2230 cxstack_ix++;
2231 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2232 redo_op = redo_op->op_next;
2233 }
2234
a0d0e21e 2235 TOPBLOCK(cx);
3280af22 2236 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2237 LEAVE_SCOPE(oldsave);
936c78b5 2238 FREETMPS;
3a1b2b9e 2239 PL_curcop = cx->blk_oldcop;
a034e688 2240 return redo_op;
a0d0e21e
LW		 2241}
2242
0824fdcb 2243STATIC OP *
bfed75c6 2244S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2245{
97aff369 2246 dVAR;
a0d0e21e 2247 OP **ops = opstack;
bfed75c6 2248 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2249
fc36a67e 2250 if (ops >= oplimit)
cea2e8a9 2251 Perl_croak(aTHX_ too_deep);
11343788
MB		 2252 if (o->op_type == OP_LEAVE ||
2253 o->op_type == OP_SCOPE ||
2254 o->op_type == OP_LEAVELOOP ||
33d34e4c 2255 o->op_type == OP_LEAVESUB ||
11343788 2256 o->op_type == OP_LEAVETRY)
fc36a67e 2257 {
5dc0d613 2258 *ops++ = cUNOPo->op_first;
fc36a67e 2259 if (ops >= oplimit)
cea2e8a9 2260 Perl_croak(aTHX_ too_deep);
fc36a67e 2261 }
c4aa4e48 2262 *ops = 0;
11343788 2263 if (o->op_flags & OPf_KIDS) {
aec46f14 2264 OP *kid;
a0d0e21e 2265 /* First try all the kids at this level, since that's likeliest. */
11343788 2266 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2267 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2268 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2269 return kid;
2270 }
11343788 2271 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2272 if (kid == PL_lastgotoprobe)
a0d0e21e 2273 continue;
ed8d0fe2
SM		 2274 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2275 if (ops == opstack)
2276 *ops++ = kid;
2277 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2278 ops[-1]->op_type == OP_DBSTATE)
2279 ops[-1] = kid;
2280 else
2281 *ops++ = kid;
2282 }
155aba94 2283 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2284 return o;
a0d0e21e
LW		 2285 }
2286 }
c4aa4e48 2287 *ops = 0;
a0d0e21e
LW		 2288 return 0;
2289}
2290
a0d0e21e
LW		 2291PP(pp_goto)
2292{
27da23d5 2293 dVAR; dSP;
cbbf8932 2294 OP *retop = NULL;
a0d0e21e 2295 I32 ix;
c09156bb 2296 register PERL_CONTEXT *cx;
fc36a67e 2297#define GOTO_DEPTH 64
2298 OP *enterops[GOTO_DEPTH];
cbbf8932 2299 const char *label = NULL;
bfed75c6
AL		 2300 const bool do_dump = (PL_op->op_type == OP_DUMP);
2301 static const char must_have_label[] = "goto must have label";
a0d0e21e 2302
533c011a 2303 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2304 SV * const sv = POPs;
a0d0e21e
LW		 2305
2306 /* This egregious kludge implements goto &subroutine */
2307 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2308 I32 cxix;
c09156bb 2309 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2310 CV* cv = (CV*)SvRV(sv);
2311 SV** mark;
2312 I32 items = 0;
2313 I32 oldsave;
b1464ded 2314 bool reified = 0;
a0d0e21e 2315
e8f7dd13 2316 retry:
4aa0a1f7 2317 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2318 const GV * const gv = CvGV(cv);
e8f7dd13 2319 if (gv) {
7fc63493 2320 GV *autogv;
e8f7dd13
GS		 2321 SV *tmpstr;
2322 /* autoloaded stub? */
2323 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2324 goto retry;
2325 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2326 GvNAMELEN(gv), FALSE);
2327 if (autogv && (cv = GvCV(autogv)))
2328 goto retry;
2329 tmpstr = sv_newmortal();
c445ea15 2330 gv_efullname3(tmpstr, gv, NULL);
be2597df 2331 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
4aa0a1f7 2332 }
cea2e8a9 2333 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2334 }
2335
a0d0e21e 2336 /* First do some returnish stuff. */
b37c2d43 2337 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
71fc2216 2338 FREETMPS;
a0d0e21e
LW		 2339 cxix = dopoptosub(cxstack_ix);
2340 if (cxix < 0)
cea2e8a9 2341 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2342 if (cxix < cxstack_ix)
2343 dounwind(cxix);
2344 TOPBLOCK(cx);
2d43a17f 2345 SPAGAIN;
564abe23 2346 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2347 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2348 if (CxREALEVAL(cx))
2349 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2350 else
2351 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2352 }
9850bf21
RH		 2353 else if (CxMULTICALL(cx))
2354 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
cc8d50a7 2355 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
d8b46c1b 2356 /* put @_ back onto stack */
a0d0e21e 2357 AV* av = cx->blk_sub.argarray;
bfed75c6 2358
93965878 2359 items = AvFILLp(av) + 1;
a45cdc79
DM		 2360 EXTEND(SP, items+1); /* @_ could have been extended. */
2361 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2362 SvREFCNT_dec(GvAV(PL_defgv));
2363 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2364 CLEAR_ARGARRAY(av);
d8b46c1b 2365 /* abandon @_ if it got reified */
62b1ebc2 2366 if (AvREAL(av)) {
b1464ded
DM		 2367 reified = 1;
2368 SvREFCNT_dec(av);
d8b46c1b
GS		 2369 av = newAV();
2370 av_extend(av, items-1);
11ca45c0 2371 AvREIFY_only(av);
dd2155a4 2372 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2373 }
a0d0e21e 2374 }
aed2304a 2375 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2376 AV* const av = GvAV(PL_defgv);
1fa4e549 2377 items = AvFILLp(av) + 1;
a45cdc79
DM		 2378 EXTEND(SP, items+1); /* @_ could have been extended. */
2379 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2380 }
a45cdc79
DM		 2381 mark = SP;
2382 SP += items;
6b35e009 2383 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2384 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2385 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2386 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2387 LEAVE_SCOPE(oldsave);
2388
2389 /* Now do some callish stuff. */
2390 SAVETMPS;
5023d17a 2391 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2392 if (CvISXSUB(cv)) {
b37c2d43 2393 OP* const retop = cx->blk_sub.retop;
f73ef291
NC		 2394 SV **newsp;
2395 I32 gimme;
b1464ded
DM		 2396 if (reified) {
2397 I32 index;
2398 for (index=0; index<items; index++)
2399 sv_2mortal(SP[-index]);
2400 }
1fa4e549 2401
b37c2d43
AL		 2402 /* XS subs don't have a CxSUB, so pop it */
2403 POPBLOCK(cx, PL_curpm);
2404 /* Push a mark for the start of arglist */
2405 PUSHMARK(mark);
2406 PUTBACK;
2407 (void)(*CvXSUB(cv))(aTHX_ cv);
a0d0e21e 2408 LEAVE;
5eff7df7 2409 return retop;
a0d0e21e
LW		 2410 }
2411 else {
b37c2d43 2412 AV* const padlist = CvPADLIST(cv);
6b35e009 2413 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2414 PL_in_eval = cx->blk_eval.old_in_eval;
2415 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22 2416 cx->cx_type = CXt_SUB;
cc8d50a7 2417 cx->blk_sub.hasargs = 0;
b150fb22 2418 }
a0d0e21e 2419 cx->blk_sub.cv = cv;
1a5b3db4 2420 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2421
a0d0e21e
LW		 2422 CvDEPTH(cv)++;
2423 if (CvDEPTH(cv) < 2)
74c765eb 2424 SvREFCNT_inc_simple_void_NN(cv);
dd2155a4 2425 else {
599cee73 2426 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2427 sub_crush_depth(cv);
26019298 2428 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2429 }
fd617465
DM		 2430 SAVECOMPPAD();
2431 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
cc8d50a7 2432 if (cx->blk_sub.hasargs)
6d4ff0d2 2433 {
b37c2d43 2434 AV* const av = (AV*)PAD_SVl(0);
a0d0e21e 2435
3280af22 2436 cx->blk_sub.savearray = GvAV(PL_defgv);
b37c2d43 2437 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
dd2155a4 2438 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2439 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2440
2441 if (items >= AvMAX(av) + 1) {
b37c2d43 2442 SV **ary = AvALLOC(av);
a0d0e21e
LW		 2443 if (AvARRAY(av) != ary) {
2444 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
9c6bc640 2445 AvARRAY(av) = ary;
a0d0e21e
LW		 2446 }
2447 if (items >= AvMAX(av) + 1) {
2448 AvMAX(av) = items - 1;
2449 Renew(ary,items+1,SV*);
2450 AvALLOC(av) = ary;
9c6bc640 2451 AvARRAY(av) = ary;
a0d0e21e
LW		 2452 }
2453 }
a45cdc79 2454 ++mark;
a0d0e21e 2455 Copy(mark,AvARRAY(av),items,SV*);
93965878 2456 AvFILLp(av) = items - 1;
d8b46c1b 2457 assert(!AvREAL(av));
b1464ded
DM		 2458 if (reified) {
2459 /* transfer 'ownership' of refcnts to new @_ */
2460 AvREAL_on(av);
2461 AvREIFY_off(av);
2462 }
a0d0e21e
LW		 2463 while (items--) {
2464 if (*mark)
2465 SvTEMP_off(*mark);
2466 mark++;
2467 }
2468 }
491527d0 2469 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
005a8a35 2470 Perl_get_db_sub(aTHX_ NULL, cv);
b37c2d43
AL		 2471 if (PERLDB_GOTO) {
2472 CV * const gotocv = get_cv("DB::goto", FALSE);
2473 if (gotocv) {
2474 PUSHMARK( PL_stack_sp );
2475 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2476 PL_stack_sp--;
2477 }
491527d0 2478 }
1ce6579f 2479 }
a0d0e21e
LW		 2480 RETURNOP(CvSTART(cv));
2481 }
2482 }
1614b0e3 2483 else {
0510663f 2484 label = SvPV_nolen_const(sv);
1614b0e3 2485 if (!(do_dump || *label))
cea2e8a9 2486 DIE(aTHX_ must_have_label);
1614b0e3 2487 }
a0d0e21e 2488 }
533c011a 2489 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2490 if (! do_dump)
cea2e8a9 2491 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2492 }
2493 else
2494 label = cPVOP->op_pv;
2495
2496 if (label && *label) {
cbbf8932 2497 OP *gotoprobe = NULL;
3b2447bc 2498 bool leaving_eval = FALSE;
33d34e4c 2499 bool in_block = FALSE;
cbbf8932 2500 PERL_CONTEXT *last_eval_cx = NULL;
a0d0e21e
LW		 2501
2502 /* find label */
2503
d4c19fe8 2504 PL_lastgotoprobe = NULL;
a0d0e21e
LW		 2505 *enterops = 0;
2506 for (ix = cxstack_ix; ix >= 0; ix--) {
2507 cx = &cxstack[ix];
6b35e009 2508 switch (CxTYPE(cx)) {
a0d0e21e 2509 case CXt_EVAL:
3b2447bc 2510 leaving_eval = TRUE;
971ecbe6 2511 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2512 gotoprobe = (last_eval_cx ?
2513 last_eval_cx->blk_eval.old_eval_root :
2514 PL_eval_root);
2515 last_eval_cx = cx;
9c5794fe
RH		 2516 break;
2517 }
2518 /* else fall through */
a0d0e21e
LW		 2519 case CXt_LOOP:
2520 gotoprobe = cx->blk_oldcop->op_sibling;
2521 break;
2522 case CXt_SUBST:
2523 continue;
2524 case CXt_BLOCK:
33d34e4c 2525 if (ix) {
a0d0e21e 2526 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2527 in_block = TRUE;
2528 } else
3280af22 2529 gotoprobe = PL_main_root;
a0d0e21e 2530 break;
b3933176 2531 case CXt_SUB:
9850bf21 2532 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
b3933176
CS		 2533 gotoprobe = CvROOT(cx->blk_sub.cv);
2534 break;
2535 }
2536 /* FALL THROUGH */
7766f137 2537 case CXt_FORMAT:
0a753a76 2538 case CXt_NULL:
a651a37d 2539 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2540 default:
2541 if (ix)
cea2e8a9 2542 DIE(aTHX_ "panic: goto");
3280af22 2543 gotoprobe = PL_main_root;
a0d0e21e
LW		 2544 break;
2545 }
2b597662
GS		 2546 if (gotoprobe) {
2547 retop = dofindlabel(gotoprobe, label,
2548 enterops, enterops + GOTO_DEPTH);
2549 if (retop)
2550 break;
2551 }
3280af22 2552 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2553 }
2554 if (!retop)
cea2e8a9 2555 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2556
3b2447bc
RH		 2557 /* if we're leaving an eval, check before we pop any frames
2558 that we're not going to punt, otherwise the error
2559 won't be caught */
2560
2561 if (leaving_eval && *enterops && enterops[1]) {
2562 I32 i;
2563 for (i = 1; enterops[i]; i++)
2564 if (enterops[i]->op_type == OP_ENTERITER)
2565 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2566 }
2567
a0d0e21e
LW		 2568 /* pop unwanted frames */
2569
2570 if (ix < cxstack_ix) {
2571 I32 oldsave;
2572
2573 if (ix < 0)
2574 ix = 0;
2575 dounwind(ix);
2576 TOPBLOCK(cx);
3280af22 2577 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2578 LEAVE_SCOPE(oldsave);
2579 }
2580
2581 /* push wanted frames */
2582
748a9306 2583 if (*enterops && enterops[1]) {
0bd48802 2584 OP * const oldop = PL_op;
33d34e4c
AE		 2585 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2586 for (; enterops[ix]; ix++) {
533c011a 2587 PL_op = enterops[ix];
84902520
TB		 2588 /* Eventually we may want to stack the needed arguments
2589 * for each op. For now, we punt on the hard ones. */
533c011a 2590 if (PL_op->op_type == OP_ENTERITER)
894356b3 2591 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2592 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2593 }
533c011a 2594 PL_op = oldop;
a0d0e21e
LW		 2595 }
2596 }
2597
2598 if (do_dump) {
a5f75d66 2599#ifdef VMS
6b88bc9c 2600 if (!retop) retop = PL_main_start;
a5f75d66 2601#endif
3280af22
NIS		 2602 PL_restartop = retop;
2603 PL_do_undump = TRUE;
a0d0e21e
LW		 2604
2605 my_unexec();
2606
3280af22
NIS		 2607 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2608 PL_do_undump = FALSE;
a0d0e21e
LW		 2609 }
2610
2611 RETURNOP(retop);
2612}
2613
2614PP(pp_exit)
2615{
97aff369 2616 dVAR;
39644a26 2617 dSP;
a0d0e21e
LW		 2618 I32 anum;
2619
2620 if (MAXARG < 1)
2621 anum = 0;
ff0cee69 2622 else {
a0d0e21e 2623 anum = SvIVx(POPs);
d98f61e7
GS		 2624#ifdef VMS
2625 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2626 anum = 0;
96e176bf 2627 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2628#endif
2629 }
cc3604b1 2630 PL_exit_flags |= PERL_EXIT_EXPECTED;
81d86705
NC		 2631#ifdef PERL_MAD
2632 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2633 if (anum || !(PL_minus_c && PL_madskills))
2634 my_exit(anum);
2635#else
a0d0e21e 2636 my_exit(anum);
81d86705 2637#endif
3280af22 2638 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2639 RETURN;
2640}
2641
a0d0e21e
LW		 2642/* Eval. */
2643
0824fdcb 2644STATIC void
cea2e8a9 2645S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2646{
504618e9 2647 const char *s = SvPVX_const(sv);
890ce7af 2648 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2649 I32 line = 1;
a0d0e21e
LW		 2650
2651 while (s && s < send) {
f54cb97a 2652 const char *t;
b9f83d2f 2653 SV * const tmpstr = newSV_type(SVt_PVMG);
a0d0e21e 2654
a0d0e21e
LW		 2655 t = strchr(s, '\n');
2656 if (t)
2657 t++;
2658 else
2659 t = send;
2660
2661 sv_setpvn(tmpstr, s, t - s);
2662 av_store(array, line++, tmpstr);
2663 s = t;
2664 }
2665}
2666
901017d6 2667STATIC void
14dd3ad8
GS		 2668S_docatch_body(pTHX)
2669{
97aff369 2670 dVAR;
cea2e8a9 2671 CALLRUNOPS(aTHX);
901017d6 2672 return;
312caa8e
CS		 2673}
2674
0824fdcb 2675STATIC OP *
cea2e8a9 2676S_docatch(pTHX_ OP *o)
1e422769 2677{
97aff369 2678 dVAR;
6224f72b 2679 int ret;
06b5626a 2680 OP * const oldop = PL_op;
db36c5a1 2681 dJMPENV;
1e422769 2682
1e422769 2683#ifdef DEBUGGING
54310121 2684 assert(CATCH_GET == TRUE);
1e422769 2685#endif
312caa8e 2686 PL_op = o;
8bffa5f8 2687
14dd3ad8 2688 JMPENV_PUSH(ret);
6224f72b 2689 switch (ret) {
312caa8e 2690 case 0:
abd70938
DM		 2691 assert(cxstack_ix >= 0);
2692 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2693 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2694 redo_body:
2695 docatch_body();
312caa8e
CS		 2696 break;
2697 case 3:
8bffa5f8 2698 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2699
2700 /* NB XXX we rely on the old popped CxEVAL still being at the top
2701 * of the stack; the way die_where() currently works, this
2702 * assumption is valid. In theory The cur_top_env value should be
2703 * returned in another global, the way retop (aka PL_restartop)
2704 * is. */
2705 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2706
2707 if (PL_restartop
2708 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2709 {
312caa8e
CS		 2710 PL_op = PL_restartop;
2711 PL_restartop = 0;
2712 goto redo_body;
2713 }
2714 /* FALL THROUGH */
2715 default:
14dd3ad8 2716 JMPENV_POP;
533c011a 2717 PL_op = oldop;
6224f72b 2718 JMPENV_JUMP(ret);
1e422769 2719 /* NOTREACHED */
1e422769 2720 }
14dd3ad8 2721 JMPENV_POP;
533c011a 2722 PL_op = oldop;
5f66b61c 2723 return NULL;
1e422769 2724}
2725
c277df42 2726OP *
bfed75c6 2727Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2728/* sv Text to convert to OP tree. */
2729/* startop op_free() this to undo. */
2730/* code Short string id of the caller. */
2731{
f7997f86 2732 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2733 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2734 PERL_CONTEXT *cx;
2735 SV **newsp;
b094c71d 2736 I32 gimme = G_VOID;
c277df42
IZ		 2737 I32 optype;
2738 OP dummy;
155aba94 2739 OP *rop;
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;
2748 lex_start(sv);
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)
2797 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2798 else
2799 rop = 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
c277df42
IZ		 2817 return rop;
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.
2866 */
2867
0824fdcb 2868STATIC OP *
a3985cdc 2869S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2870{
27da23d5 2871 dVAR; dSP;
46c461b5 2872 OP * const saveop = PL_op;
a0d0e21e 2873
6dc8a9e4
IZ		 2874 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2875 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2876 : EVAL_INEVAL);
a0d0e21e 2877
1ce6579f 2878 PUSHMARK(SP);
2879
3280af22 2880 SAVESPTR(PL_compcv);
b9f83d2f 2881 PL_compcv = (CV*)newSV_type(SVt_PVCV);
1aff0e91 2882 CvEVAL_on(PL_compcv);
2090ab20
JH		 2883 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2884 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2885
a3985cdc 2886 CvOUTSIDE_SEQ(PL_compcv) = seq;
b37c2d43 2887 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
a3985cdc 2888
dd2155a4 2889 /* set up a scratch pad */
a0d0e21e 2890
dd2155a4 2891 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
cecbe010 2892 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2c05e328 2893
07055b4c 2894
81d86705
NC		 2895 if (!PL_madskills)
2896 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2897
a0d0e21e
LW		 2898 /* make sure we compile in the right package */
2899
ed094faf 2900 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2901 SAVESPTR(PL_curstash);
ed094faf 2902 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2903 }
3c10abe3 2904 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3280af22
NIS		 2905 SAVESPTR(PL_beginav);
2906 PL_beginav = newAV();
2907 SAVEFREESV(PL_beginav);
3c10abe3
AG		 2908 SAVESPTR(PL_unitcheckav);
2909 PL_unitcheckav = newAV();
2910 SAVEFREESV(PL_unitcheckav);
24944567 2911 SAVEI32(PL_error_count);
a0d0e21e 2912
81d86705 2913#ifdef PERL_MAD
9da243ce 2914 SAVEBOOL(PL_madskills);
81d86705
NC		 2915 PL_madskills = 0;
2916#endif
2917
a0d0e21e
LW		 2918 /* try to compile it */
2919
5f66b61c 2920 PL_eval_root = NULL;
3280af22
NIS		 2921 PL_error_count = 0;
2922 PL_curcop = &PL_compiling;
fc15ae8f 2923 CopARYBASE_set(PL_curcop, 0);
5f66b61c 2924 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 2925 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2926 else
c69006e4 2927 sv_setpvn(ERRSV,"",0);
3280af22 2928 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2929 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2930 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2931 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2932 const char *msg;
bfed75c6 2933
533c011a 2934 PL_op = saveop;
3280af22
NIS		 2935 if (PL_eval_root) {
2936 op_free(PL_eval_root);
5f66b61c 2937 PL_eval_root = NULL;
a0d0e21e 2938 }
3280af22 2939 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2940 if (!startop) {
3280af22 2941 POPBLOCK(cx,PL_curpm);
c277df42 2942 POPEVAL(cx);
c277df42 2943 }
a0d0e21e
LW		 2944 lex_end();
2945 LEAVE;
9d4ba2ae
AL		 2946
2947 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2948 if (optype == OP_REQUIRE) {
b464bac0 2949 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2950 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2951 &PL_sv_undef, 0);
5a844595
GS		 2952 DIE(aTHX_ "%sCompilation failed in require",
2953 *msg ? msg : "Unknown error\n");
2954 }
2955 else if (startop) {
3280af22 2956 POPBLOCK(cx,PL_curpm);
c277df42 2957 POPEVAL(cx);
5a844595
GS		 2958 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2959 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2960 }
9d7f88dd 2961 else {
9d7f88dd 2962 if (!*msg) {
6502358f 2963 sv_setpvs(ERRSV, "Compilation error");
9d7f88dd
SR		 2964 }
2965 }
9d4ba2ae 2966 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW		 2967 RETPUSHUNDEF;
2968 }
57843af0 2969 CopLINE_set(&PL_compiling, 0);
c277df42 2970 if (startop) {
3280af22 2971 *startop = PL_eval_root;
c277df42 2972 } else
3280af22 2973 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2974
2975 /* Set the context for this new optree.
2976 * If the last op is an OP_REQUIRE, force scalar context.
2977 * Otherwise, propagate the context from the eval(). */
2978 if (PL_eval_root->op_type == OP_LEAVEEVAL
2979 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2980 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2981 == OP_REQUIRE)
2982 scalar(PL_eval_root);
2983 else if (gimme & G_VOID)
3280af22 2984 scalarvoid(PL_eval_root);
54310121 2985 else if (gimme & G_ARRAY)
3280af22 2986 list(PL_eval_root);
a0d0e21e 2987 else
3280af22 2988 scalar(PL_eval_root);
a0d0e21e
LW		 2989
2990 DEBUG_x(dump_eval());
2991
55497cff 2992 /* Register with debugger: */
6482a30d 2993 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
890ce7af 2994 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff 2995 if (cv) {
2996 dSP;
924508f0 2997 PUSHMARK(SP);
cc49e20b 2998 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2999 PUTBACK;
864dbfa3 3000 call_sv((SV*)cv, G_DISCARD);
55497cff 3001 }
3002 }
3003
3c10abe3
AG		 3004 if (PL_unitcheckav)
3005 call_list(PL_scopestack_ix, PL_unitcheckav);
3006
a0d0e21e
LW		 3007 /* compiled okay, so do it */
3008
3280af22
NIS		 3009 CvDEPTH(PL_compcv) = 1;
3010 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3011 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3012 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3013
3280af22 3014 RETURNOP(PL_eval_start);
a0d0e21e
LW		 3015}
3016
a6c40364 3017STATIC PerlIO *
74d5ed12 3018S_check_type_and_open(pTHX_ const char *name, const char *mode)
ce8abf5f
SP		 3019{
3020 Stat_t st;
c445ea15 3021 const int st_rc = PerlLIO_stat(name, &st);
df528165 3022
6b845e56 3023 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
4608196e 3024 return NULL;
ce8abf5f
SP		 3025 }
3026
ce8abf5f
SP		 3027 return PerlIO_open(name, mode);
3028}
3029
3030STATIC PerlIO *
7925835c 3031S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3032{
7925835c 3033#ifndef PERL_DISABLE_PMC
f54cb97a 3034 const STRLEN namelen = strlen(name);
b295d113
TH		 3035 PerlIO *fp;
3036
7894fbab 3037 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3038 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3039 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS		 3040 Stat_t pmcstat;
3041 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
85e8f315 3042 fp = check_type_and_open(name, mode);
a6c40364
GS		 3043 }
3044 else {
a91233bf 3045 fp = check_type_and_open(pmc, mode);
b295d113 3046 }
a6c40364
GS		 3047 SvREFCNT_dec(pmcsv);
3048 }
3049 else {
85e8f315 3050 fp = check_type_and_open(name, mode);
b295d113 3051 }
b295d113 3052 return fp;
7925835c 3053#else
85e8f315 3054 return check_type_and_open(name, mode);
7925835c 3055#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3056}
3057
a0d0e21e
LW		 3058PP(pp_require)
3059{
27da23d5 3060 dVAR; dSP;
c09156bb 3061 register PERL_CONTEXT *cx;
a0d0e21e 3062 SV *sv;
5c144d81 3063 const char *name;
6132ea6c 3064 STRLEN len;
c445ea15
AL		 3065 const char *tryname = NULL;
3066 SV *namesv = NULL;
f54cb97a 3067 const I32 gimme = GIMME_V;
bbed91b5 3068 int filter_has_file = 0;
c445ea15 3069 PerlIO *tryrsfp = NULL;
34113e50 3070 SV *filter_cache = NULL;
c445ea15
AL		 3071 SV *filter_state = NULL;
3072 SV *filter_sub = NULL;
3073 SV *hook_sv = NULL;
6ec9efec
JH		 3074 SV *encoding;
3075 OP *op;
a0d0e21e
LW		 3076
3077 sv = POPs;
d7aa5382
JP		 3078 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3079 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3080 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3081 "v-string in use/require non-portable");
d7aa5382
JP		 3082
3083 sv = new_version(sv);
3084 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3085 upg_version(PL_patchlevel, TRUE);
149c1637 3086 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3cacfbb9 3087 if ( vcmp(sv,PL_patchlevel) <= 0 )
468aa647 3088 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
be2597df 3089 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
468aa647
RGS		 3090 }
3091 else {
3092 if ( vcmp(sv,PL_patchlevel) > 0 )
3093 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
be2597df 3094 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
468aa647 3095 }
d7aa5382 3096
7dfde25d
RGS		 3097 /* If we request a version >= 5.9.5, load feature.pm with the
3098 * feature bundle that corresponds to the required version.
3099 * We do this only with use, not require. */
ac0e6a2f 3100 if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
7dfde25d
RGS		 3101 SV *const importsv = vnormal(sv);
3102 *SvPVX_mutable(importsv) = ':';
3103 ENTER;
3104 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3105 LEAVE;
3106 }
3107
3108 RETPUSHYES;
a0d0e21e 3109 }
5c144d81 3110 name = SvPV_const(sv, len);
6132ea6c 3111 if (!(name && len > 0 && *name))
cea2e8a9 3112 DIE(aTHX_ "Null filename used");
4633a7c4 3113 TAINT_PROPER("require");
44f8325f 3114 if (PL_op->op_type == OP_REQUIRE) {
0bd48802 3115 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
44f8325f
AL		 3116 if ( svp ) {
3117 if (*svp != &PL_sv_undef)
3118 RETPUSHYES;
3119 else
3120 DIE(aTHX_ "Compilation failed in require");
3121 }
4d8b06f1 3122 }
a0d0e21e
LW		 3123
3124 /* prepare to compile file */
3125
be4b629d 3126 if (path_is_absolute(name)) {
46fc3d4c 3127 tryname = name;
7925835c 3128 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3129 }
67627c52
JH		 3130#ifdef MACOS_TRADITIONAL
3131 if (!tryrsfp) {
3132 char newname[256];
3133
3134 MacPerl_CanonDir(name, newname, 1);
3135 if (path_is_absolute(newname)) {
3136 tryname = newname;
7925835c 3137 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3138 }
3139 }
3140#endif
be4b629d 3141 if (!tryrsfp) {
44f8325f 3142 AV * const ar = GvAVn(PL_incgv);
a0d0e21e 3143 I32 i;
748a9306 3144#ifdef VMS
46fc3d4c 3145 char *unixname;
c445ea15 3146 if ((unixname = tounixspec(name, NULL)) != NULL)
46fc3d4c 3147#endif
3148 {
561b68a9 3149 namesv = newSV(0);
46fc3d4c 3150 for (i = 0; i <= AvFILL(ar); i++) {
df528165 3151 SV * const dirsv = *av_fetch(ar, i, TRUE);
bbed91b5 3152
c38a6530
RD		 3153 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3154 mg_get(dirsv);
bbed91b5
KF		 3155 if (SvROK(dirsv)) {
3156 int count;
a3b58a99 3157 SV **svp;
bbed91b5
KF		 3158 SV *loader = dirsv;
3159
e14e2dc8
NC		 3160 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3161 && !sv_isobject(loader))
3162 {
bbed91b5
KF		 3163 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3164 }
3165
b900a521 3166 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3167 PTR2UV(SvRV(dirsv)), name);
349d4f2f 3168 tryname = SvPVX_const(namesv);
c445ea15 3169 tryrsfp = NULL;
bbed91b5
KF		 3170
3171 ENTER;
3172 SAVETMPS;
3173 EXTEND(SP, 2);
3174
3175 PUSHMARK(SP);
3176 PUSHs(dirsv);
3177 PUSHs(sv);
3178 PUTBACK;
e982885c
NC		 3179 if (sv_isobject(loader))
3180 count = call_method("INC", G_ARRAY);
3181 else
3182 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3183 SPAGAIN;
3184
a3b58a99
RGS		 3185 /* Adjust file name if the hook has set an %INC entry */
3186 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3187 if (svp)
3188 tryname = SvPVX_const(*svp);
3189
bbed91b5
KF		 3190 if (count > 0) {
3191 int i = 0;
3192 SV *arg;
3193
3194 SP -= count - 1;
3195 arg = SP[i++];
3196
34113e50
NC		 3197 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3198 && !isGV_with_GP(SvRV(arg))) {
3199 filter_cache = SvRV(arg);
74c765eb 3200 SvREFCNT_inc_simple_void_NN(filter_cache);
34113e50
NC		 3201
3202 if (i < count) {
3203 arg = SP[i++];
3204 }
3205 }
3206
bbed91b5
KF		 3207 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3208 arg = SvRV(arg);
3209 }
3210
3211 if (SvTYPE(arg) == SVt_PVGV) {
df528165 3212 IO * const io = GvIO((GV *)arg);
bbed91b5
KF		 3213
3214 ++filter_has_file;
3215
3216 if (io) {
3217 tryrsfp = IoIFP(io);
0f7de14d
NC		 3218 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3219 PerlIO_close(IoOFP(io));
bbed91b5 3220 }
0f7de14d
NC		 3221 IoIFP(io) = NULL;
3222 IoOFP(io) = NULL;
bbed91b5
KF		 3223 }
3224
3225 if (i < count) {
3226 arg = SP[i++];
3227 }
3228 }
3229
3230 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3231 filter_sub = arg;
74c765eb 3232 SvREFCNT_inc_simple_void_NN(filter_sub);
bbed91b5
KF		 3233
3234 if (i < count) {
3235 filter_state = SP[i];
b37c2d43 3236 SvREFCNT_inc_simple_void(filter_state);
bbed91b5 3237 }
34113e50 3238 }
bbed91b5 3239
34113e50
NC		 3240 if (!tryrsfp && (filter_cache || filter_sub)) {
3241 tryrsfp = PerlIO_open(BIT_BUCKET,
3242 PERL_SCRIPT_MODE);
bbed91b5 3243 }
1d06aecd 3244 SP--;
bbed91b5
KF		 3245 }
3246
3247 PUTBACK;
3248 FREETMPS;
3249 LEAVE;
3250
3251 if (tryrsfp) {
89ccab8c 3252 hook_sv = dirsv;
bbed91b5
KF		 3253 break;
3254 }
3255
3256 filter_has_file = 0;
34113e50
NC		 3257 if (filter_cache) {
3258 SvREFCNT_dec(filter_cache);
3259 filter_cache = NULL;
3260 }
bbed91b5
KF		 3261 if (filter_state) {
3262 SvREFCNT_dec(filter_state);
c445ea15 3263 filter_state = NULL;
bbed91b5
KF		 3264 }
3265 if (filter_sub) {
3266 SvREFCNT_dec(filter_sub);
c445ea15 3267 filter_sub = NULL;
bbed91b5
KF		 3268 }
3269 }
3270 else {
be4b629d
CN		 3271 if (!path_is_absolute(name)
3272#ifdef MACOS_TRADITIONAL
3273 /* We consider paths of the form :a:b ambiguous and interpret them first
3274 as global then as local
3275 */
3276 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3277#endif
3278 ) {
4ea561bc 3279 const char *dir = SvPV_nolen_const(dirsv);
bf4acbe4 3280#ifdef MACOS_TRADITIONAL
67627c52
JH		 3281 char buf1[256];
3282 char buf2[256];
3283
3284 MacPerl_CanonDir(name, buf2, 1);
3285 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3286#else
27da23d5 3287# ifdef VMS
bbed91b5 3288 char *unixdir;
c445ea15 3289 if ((unixdir = tounixpath(dir, NULL)) == NULL)
bbed91b5
KF		 3290 continue;
3291 sv_setpv(namesv, unixdir);
3292 sv_catpv(namesv, unixname);
27da23d5 3293# else
a0fd4948 3294# ifdef __SYMBIAN32__
27da23d5
JH		 3295 if (PL_origfilename[0] &&
3296 PL_origfilename[1] == ':' &&
3297 !(dir[0] && dir[1] == ':'))
3298 Perl_sv_setpvf(aTHX_ namesv,
3299 "%c:%s\\%s",
3300 PL_origfilename[0],
3301 dir, name);
3302 else
3303 Perl_sv_setpvf(aTHX_ namesv,
3304 "%s\\%s",
3305 dir, name);
3306# else
bbed91b5 3307 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH		 3308# endif
3309# endif
bf4acbe4 3310#endif
bbed91b5 3311 TAINT_PROPER("require");
349d4f2f 3312 tryname = SvPVX_const(namesv);
7925835c 3313 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3314 if (tryrsfp) {
3315 if (tryname[0] == '.' && tryname[1] == '/')
3316 tryname += 2;
3317 break;
3318 }
ff806af2
DM		 3319 else if (errno == EMFILE)
3320 /* no point in trying other paths if out of handles */
3321 break;
be4b629d 3322 }
46fc3d4c 3323 }
a0d0e21e
LW		 3324 }
3325 }
3326 }
f4dd75d9 3327 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3328 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3329 SvREFCNT_dec(namesv);
a0d0e21e 3330 if (!tryrsfp) {
533c011a 3331 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3332 const char *msgstr = name;
e31de809 3333 if(errno == EMFILE) {
b9b739dc
NC		 3334 SV * const msg
3335 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3336 Strerror(errno)));
349d4f2f 3337 msgstr = SvPV_nolen_const(msg);
e31de809
SP		 3338 } else {
3339 if (namesv) { /* did we lookup @INC? */
44f8325f 3340 AV * const ar = GvAVn(PL_incgv);
e31de809 3341 I32 i;
b8f04b1b
NC		 3342 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3343 "%s in @INC%s%s (@INC contains:",
3344 msgstr,
3345 (instr(msgstr, ".h ")
3346 ? " (change .h to .ph maybe?)" : ""),
3347 (instr(msgstr, ".ph ")
3348 ? " (did you run h2ph?)" : "")
3349 ));
3350
e31de809 3351 for (i = 0; i <= AvFILL(ar); i++) {
396482e1 3352 sv_catpvs(msg, " ");
b8f04b1b 3353 sv_catsv(msg, *av_fetch(ar, i, TRUE));
e31de809 3354 }
396482e1 3355 sv_catpvs(msg, ")");
e31de809
SP		 3356 msgstr = SvPV_nolen_const(msg);
3357 }
2683423c 3358 }
ea071790 3359 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3360 }
3361
3362 RETPUSHUNDEF;
3363 }
d8bfb8bd 3364 else
93189314 3365 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3366
3367 /* Assume success here to prevent recursive requirement. */
238d24b4 3368 /* name is never assigned to again, so len is still strlen(name) */
d3a4e64e 3369 /* Check whether a hook in @INC has already filled %INC */
44f8325f
AL		 3370 if (!hook_sv) {
3371 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3372 } else {
3373 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3374 if (!svp)
b37c2d43 3375 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
d3a4e64e 3376 }
a0d0e21e
LW		 3377
3378 ENTER;
3379 SAVETMPS;
10efb74f 3380 lex_start(NULL);
b9d12d37 3381 SAVEGENERICSV(PL_rsfp_filters);
7d49f689 3382 PL_rsfp_filters = NULL;
e50aee73 3383
3280af22 3384 PL_rsfp = tryrsfp;
b3ac6de7 3385 SAVEHINTS();
3280af22 3386 PL_hints = 0;
68da3b2f 3387 SAVECOMPILEWARNINGS();
0453d815 3388 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3389 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3390 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3391 PL_compiling.cop_warnings = pWARN_NONE ;
ac27b0f5 3392 else
d3a7d8c7 3393 PL_compiling.cop_warnings = pWARN_STD ;
a0d0e21e 3394
34113e50 3395 if (filter_sub || filter_cache) {
c445ea15 3396 SV * const datasv = filter_add(S_run_user_filter, NULL);
bbed91b5 3397 IoLINES(datasv) = filter_has_file;
bbed91b5
KF		 3398 IoTOP_GV(datasv) = (GV *)filter_state;
3399 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
34113e50 3400 IoFMT_GV(datasv) = (GV *)filter_cache;
bbed91b5
KF		 3401 }
3402
3403 /* switch to eval mode */
a0d0e21e 3404 PUSHBLOCK(cx, CXt_EVAL, SP);
a0714e2c 3405 PUSHEVAL(cx, name, NULL);
f39bc417 3406 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3407
57843af0
GS		 3408 SAVECOPLINE(&PL_compiling);
3409 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3410
3411 PUTBACK;
6ec9efec
JH		 3412
3413 /* Store and reset encoding. */
3414 encoding = PL_encoding;
c445ea15 3415 PL_encoding = NULL;
6ec9efec 3416
601f1833 3417 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
bfed75c6 3418
6ec9efec
JH		 3419 /* Restore encoding. */
3420 PL_encoding = encoding;
3421
3422 return op;
a0d0e21e
LW		 3423}
3424
a0d0e21e
LW		 3425PP(pp_entereval)
3426{
27da23d5 3427 dVAR; dSP;
c09156bb 3428 register PERL_CONTEXT *cx;
0d863452 3429 SV *sv;
890ce7af
AL		 3430 const I32 gimme = GIMME_V;
3431 const I32 was = PL_sub_generation;
83ee9e09
GS		 3432 char tbuf[TYPE_DIGITS(long) + 12];
3433 char *tmpbuf = tbuf;
fc36a67e 3434 char *safestr;
a0d0e21e 3435 STRLEN len;
55497cff 3436 OP *ret;
a3985cdc 3437 CV* runcv;
d819b83a 3438 U32 seq;
c445ea15 3439 HV *saved_hh = NULL;
e80fed9d 3440 const char * const fakestr = "_<(eval )";
e80fed9d 3441 const int fakelen = 9 + 1;
0d863452
RH		 3442
3443 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3444 saved_hh = (HV*) SvREFCNT_inc(POPs);
3445 }
3446 sv = POPs;
a0d0e21e 3447
af2d3def 3448 TAINT_IF(SvTAINTED(sv));
748a9306 3449 TAINT_PROPER("eval");
a0d0e21e
LW		 3450
3451 ENTER;
a0d0e21e 3452 lex_start(sv);
748a9306 3453 SAVETMPS;
ac27b0f5 3454
a0d0e21e
LW		 3455 /* switch to eval mode */
3456
83ee9e09 3457 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
8b38226b
AL		 3458 SV * const temp_sv = sv_newmortal();
3459 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
83ee9e09
GS		 3460 (unsigned long)++PL_evalseq,
3461 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8b38226b
AL		 3462 tmpbuf = SvPVX(temp_sv);
3463 len = SvCUR(temp_sv);
83ee9e09
GS		 3464 }
3465 else
d9fad198 3466 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3467 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3468 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3469 SAVECOPLINE(&PL_compiling);
57843af0 3470 CopLINE_set(&PL_compiling, 1);
55497cff 3471 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3472 deleting the eval's FILEGV from the stash before gv_check() runs
3473 (i.e. before run-time proper). To work around the coredump that
3474 ensues, we always turn GvMULTI_on for any globals that were
3475 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 3476 safestr = savepvn(tmpbuf, len);
3477 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 3478 SAVEHINTS();
533c011a 3479 PL_hints = PL_op->op_targ;
0d863452
RH		 3480 if (saved_hh)
3481 GvHV(PL_hintgv) = saved_hh;
68da3b2f 3482 SAVECOMPILEWARNINGS();
72dc9ed5 3483 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 3484 if (PL_compiling.cop_hints_hash) {
3485 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
a24d89c9 3486 }
c28fe1ec
NC		 3487 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3488 if (PL_compiling.cop_hints_hash) {
cbb1fbea 3489 HINTS_REFCNT_LOCK;
c28fe1ec 3490 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 3491 HINTS_REFCNT_UNLOCK;
a24d89c9 3492 }
d819b83a
DM		 3493 /* special case: an eval '' executed within the DB package gets lexically
3494 * placed in the first non-DB CV rather than the current CV - this
3495 * allows the debugger to execute code, find lexicals etc, in the
3496 * scope of the code being debugged. Passing &seq gets find_runcv
3497 * to do the dirty work for us */
3498 runcv = find_runcv(&seq);
a0d0e21e 3499
6b35e009 3500 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
a0714e2c 3501 PUSHEVAL(cx, 0, NULL);
f39bc417 3502 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 3503
3504 /* prepare to compile string */
3505
3280af22 3506 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3507 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3508 PUTBACK;
d819b83a 3509 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3510 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3511 && ret != PL_op->op_next) { /* Successive compilation. */
e80fed9d 3512 /* Copy in anything fake and short. */
28f0d0ec 3513 my_strlcpy(safestr, fakestr, fakelen);
55497cff 3514 }
1e422769 3515 return DOCATCH(ret);
a0d0e21e
LW		 3516}
3517
3518PP(pp_leaveeval)
3519{
27da23d5 3520 dVAR; dSP;
a0d0e21e
LW		 3521 register SV **mark;
3522 SV **newsp;
3523 PMOP *newpm;
3524 I32 gimme;
c09156bb 3525 register PERL_CONTEXT *cx;
a0d0e21e 3526 OP *retop;
06b5626a 3527 const U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3528 I32 optype;
3529
3530 POPBLOCK(cx,newpm);
3531 POPEVAL(cx);
f39bc417 3532 retop = cx->blk_eval.retop;
a0d0e21e 3533
a1f49e72 3534 TAINT_NOT;
54310121 3535 if (gimme == G_VOID)
3536 MARK = newsp;
3537 else if (gimme == G_SCALAR) {
3538 MARK = newsp + 1;
3539 if (MARK <= SP) {
3540 if (SvFLAGS(TOPs) & SVs_TEMP)
3541 *MARK = TOPs;
3542 else
3543 *MARK = sv_mortalcopy(TOPs);
3544 }
a0d0e21e 3545 else {
54310121 3546 MEXTEND(mark,0);
3280af22 3547 *MARK = &PL_sv_undef;
a0d0e21e 3548 }
a7ec2b44 3549 SP = MARK;
a0d0e21e
LW		 3550 }
3551 else {
a1f49e72
CS		 3552 /* in case LEAVE wipes old return values */
3553 for (mark = newsp + 1; mark <= SP; mark++) {
3554 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3555 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3556 TAINT_NOT; /* Each item is independent */
3557 }
3558 }
a0d0e21e 3559 }
3280af22 3560 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3561
4fdae800 3562#ifdef DEBUGGING
3280af22 3563 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3564#endif
3280af22 3565 CvDEPTH(PL_compcv) = 0;
f46d017c 3566 lex_end();
4fdae800 3567
1ce6579f 3568 if (optype == OP_REQUIRE &&
924508f0 3569 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3570 {
1ce6579f 3571 /* Unassume the success we assumed earlier. */
901017d6 3572 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 3573 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
be2597df 3574 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
f46d017c
GS		 3575 /* die_where() did LEAVE, or we won't be here */
3576 }
3577 else {
3578 LEAVE;
3579 if (!(save_flags & OPf_SPECIAL))
c69006e4 3580 sv_setpvn(ERRSV,"",0);
a0d0e21e 3581 }
a0d0e21e
LW		 3582
3583 RETURNOP(retop);
3584}
3585
edb2152a
NC		 3586/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3587 close to the related Perl_create_eval_scope. */
3588void
3589Perl_delete_eval_scope(pTHX)
a0d0e21e 3590{
edb2152a
NC		 3591 SV **newsp;
3592 PMOP *newpm;
3593 I32 gimme;
c09156bb 3594 register PERL_CONTEXT *cx;
edb2152a
NC		 3595 I32 optype;
3596
3597 POPBLOCK(cx,newpm);
3598 POPEVAL(cx);
3599 PL_curpm = newpm;
3600 LEAVE;
3601 PERL_UNUSED_VAR(newsp);
3602 PERL_UNUSED_VAR(gimme);
3603 PERL_UNUSED_VAR(optype);
3604}
a0d0e21e 3605
edb2152a
NC		 3606/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3607 also needed by Perl_fold_constants. */
3608PERL_CONTEXT *
3609Perl_create_eval_scope(pTHX_ U32 flags)
3610{
3611 PERL_CONTEXT *cx;
3612 const I32 gimme = GIMME_V;
3613
a0d0e21e
LW		 3614 ENTER;
3615 SAVETMPS;
3616
edb2152a 3617 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
a0d0e21e 3618 PUSHEVAL(cx, 0, 0);
a0d0e21e 3619
faef0170 3620 PL_in_eval = EVAL_INEVAL;
edb2152a
NC		 3621 if (flags & G_KEEPERR)
3622 PL_in_eval |= EVAL_KEEPERR;
3623 else
3624 sv_setpvn(ERRSV,"",0);
3625 if (flags & G_FAKINGEVAL) {
3626 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3627 }
3628 return cx;
3629}
3630
3631PP(pp_entertry)
3632{
3633 dVAR;
df528165 3634 PERL_CONTEXT * const cx = create_eval_scope(0);
edb2152a 3635 cx->blk_eval.retop = cLOGOP->op_other->op_next;
533c011a 3636 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3637}
3638
3639PP(pp_leavetry)
3640{
27da23d5 3641 dVAR; dSP;
a0d0e21e
LW		 3642 SV **newsp;
3643 PMOP *newpm;
3644 I32 gimme;
c09156bb 3645 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3646 I32 optype;
3647
3648 POPBLOCK(cx,newpm);
3649 POPEVAL(cx);
9d4ba2ae 3650 PERL_UNUSED_VAR(optype);
a0d0e21e 3651
a1f49e72 3652 TAINT_NOT;
54310121 3653 if (gimme == G_VOID)
3654 SP = newsp;
3655 else if (gimme == G_SCALAR) {
c445ea15 3656 register SV **mark;
54310121 3657 MARK = newsp + 1;
3658 if (MARK <= SP) {
3659 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3660 *MARK = TOPs;
3661 else
3662 *MARK = sv_mortalcopy(TOPs);
3663 }
a0d0e21e 3664 else {
54310121 3665 MEXTEND(mark,0);
3280af22 3666 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3667 }
3668 SP = MARK;
3669 }
3670 else {
a1f49e72 3671 /* in case LEAVE wipes old return values */
c445ea15 3672 register SV **mark;
a1f49e72
CS		 3673 for (mark = newsp + 1; mark <= SP; mark++) {
3674 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3675 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3676 TAINT_NOT; /* Each item is independent */
3677 }
3678 }
a0d0e21e 3679 }
3280af22 3680 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3681
3682 LEAVE;
c69006e4 3683 sv_setpvn(ERRSV,"",0);
745cf2ff 3684 RETURN;
a0d0e21e
LW		 3685}
3686
0d863452
RH		 3687PP(pp_entergiven)
3688{
3689 dVAR; dSP;
3690 register PERL_CONTEXT *cx;
3691 const I32 gimme = GIMME_V;
3692
3693 ENTER;
3694 SAVETMPS;
3695
3696 if (PL_op->op_targ == 0) {
c445ea15 3697 SV ** const defsv_p = &GvSV(PL_defgv);
0d863452
RH		 3698 *defsv_p = newSVsv(POPs);
3699 SAVECLEARSV(*defsv_p);
3700 }
3701 else
3702 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3703
3704 PUSHBLOCK(cx, CXt_GIVEN, SP);
3705 PUSHGIVEN(cx);
3706
3707 RETURN;
3708}
3709
3710PP(pp_leavegiven)
3711{
3712 dVAR; dSP;
3713 register PERL_CONTEXT *cx;
3714 I32 gimme;
3715 SV **newsp;
3716 PMOP *newpm;
96a5add6 3717 PERL_UNUSED_CONTEXT;
0d863452
RH		 3718
3719 POPBLOCK(cx,newpm);
3720 assert(CxTYPE(cx) == CXt_GIVEN);
0d863452
RH		 3721
3722 SP = newsp;
3723 PUTBACK;
3724
3725 PL_curpm = newpm; /* pop $1 et al */
3726
3727 LEAVE;
3728
3729 return NORMAL;
3730}
3731
3732/* Helper routines used by pp_smartmatch */
4136a0f7 3733STATIC PMOP *
0d863452
RH		 3734S_make_matcher(pTHX_ regexp *re)
3735{
97aff369 3736 dVAR;
0d863452
RH		 3737 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3738 PM_SETRE(matcher, ReREFCNT_inc(re));
3739
3740 SAVEFREEOP((OP *) matcher);
3741 ENTER; SAVETMPS;
3742 SAVEOP();
3743 return matcher;
3744}
3745
4136a0f7 3746STATIC bool
0d863452
RH		 3747S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3748{
97aff369 3749 dVAR;
0d863452
RH		 3750 dSP;
3751
3752 PL_op = (OP *) matcher;
3753 XPUSHs(sv);
3754 PUTBACK;
3755 (void) pp_match();
3756 SPAGAIN;
3757 return (SvTRUEx(POPs));
3758}
3759
4136a0f7 3760STATIC void
0d863452
RH		 3761S_destroy_matcher(pTHX_ PMOP *matcher)
3762{
97aff369 3763 dVAR;
0d863452
RH		 3764 PERL_UNUSED_ARG(matcher);
3765 FREETMPS;
3766 LEAVE;
3767}
3768
3769/* Do a smart match */
3770PP(pp_smartmatch)
3771{
a0714e2c 3772 return do_smartmatch(NULL, NULL);
0d863452
RH		 3773}
3774
4b021f5f
RGS		 3775/* This version of do_smartmatch() implements the
3776 * table of smart matches that is found in perlsyn.
0d863452 3777 */
4136a0f7 3778STATIC OP *
0d863452
RH		 3779S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3780{
97aff369 3781 dVAR;
0d863452
RH		 3782 dSP;
3783
3784 SV *e = TOPs; /* e is for 'expression' */
3785 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
10edeb5d 3786 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
0d863452
RH		 3787 MAGIC *mg;
3788 regexp *this_regex, *other_regex;
3789
3790# define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3791
3792# define SM_REF(type) ( \
10edeb5d
JH		 3793 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3794 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
0d863452
RH		 3795
3796# define SM_CV_NEP /* Find a code ref without an empty prototype */ \
10edeb5d
JH		 3797 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3798 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3799 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3800 && NOT_EMPTY_PROTO(This) && (Other = d)))
0d863452
RH		 3801
3802# define SM_REGEX ( \
10edeb5d
JH		 3803 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3804 && (mg = mg_find(This, PERL_MAGIC_qr)) \
0d863452 3805 && (this_regex = (regexp *)mg->mg_obj) \
10edeb5d 3806 && (Other = e)) \
0d863452 3807 || \
10edeb5d
JH		 3808 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3809 && (mg = mg_find(This, PERL_MAGIC_qr)) \
0d863452 3810 && (this_regex = (regexp *)mg->mg_obj) \
10edeb5d 3811 && (Other = d)) )
0d863452
RH		 3812
3813
3814# define SM_OTHER_REF(type) \
10edeb5d 3815 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
0d863452 3816
10edeb5d
JH		 3817# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3818 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
0d863452
RH		 3819 && (other_regex = (regexp *)mg->mg_obj))
3820
3821
3822# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
98f4023c 3823 sv_2mortal(newSViv(PTR2IV(sv))), 0)
0d863452
RH		 3824
3825# define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
98f4023c 3826 sv_2mortal(newSViv(PTR2IV(sv))), 0)
0d863452
RH		 3827
3828 tryAMAGICbinSET(smart, 0);
3829
3830 SP -= 2; /* Pop the values */
3831
3832 /* Take care only to invoke mg_get() once for each argument.
3833 * Currently we do this by copying the SV if it's magical. */
3834 if (d) {
3835 if (SvGMAGICAL(d))
3836 d = sv_mortalcopy(d);
3837 }
3838 else
3839 d = &PL_sv_undef;
3840
3841 assert(e);
3842 if (SvGMAGICAL(e))
3843 e = sv_mortalcopy(e);
3844
3845 if (SM_CV_NEP) {
3846 I32 c;
3847
10edeb5d 3848 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
0d863452 3849 {
10edeb5d 3850 if (This == SvRV(Other))
0d863452
RH		 3851 RETPUSHYES;
3852 else
3853 RETPUSHNO;
3854 }
3855
3856 ENTER;
3857 SAVETMPS;
3858 PUSHMARK(SP);
10edeb5d 3859 PUSHs(Other);
0d863452 3860 PUTBACK;
10edeb5d 3861 c = call_sv(This, G_SCALAR);
0d863452
RH		 3862 SPAGAIN;
3863 if (c == 0)
3864 PUSHs(&PL_sv_no);
3865 else if (SvTEMP(TOPs))
df528165 3866 SvREFCNT_inc_void(TOPs);
0d863452
RH		 3867 FREETMPS;
3868 LEAVE;
3869 RETURN;
3870 }
3871 else if (SM_REF(PVHV)) {
3872 if (SM_OTHER_REF(PVHV)) {
3873 /* Check that the key-sets are identical */
3874 HE *he;
10edeb5d 3875 HV *other_hv = (HV *) SvRV(Other);
0d863452
RH		 3876 bool tied = FALSE;
3877 bool other_tied = FALSE;
3878 U32 this_key_count = 0,
3879 other_key_count = 0;
3880
3881 /* Tied hashes don't know how many keys they have. */
10edeb5d 3882 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
0d863452
RH		 3883 tied = TRUE;
3884 }
3885 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
c445ea15 3886 HV * const temp = other_hv;
10edeb5d
JH		 3887 other_hv = (HV *) This;
3888 This = (SV *) temp;
0d863452
RH		 3889 tied = TRUE;
3890 }
3891 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3892 other_tied = TRUE;
3893
10edeb5d 3894 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
0d863452
RH		 3895 RETPUSHNO;
3896
3897 /* The hashes have the same number of keys, so it suffices
3898 to check that one is a subset of the other. */
10edeb5d
JH		 3899 (void) hv_iterinit((HV *) This);
3900 while ( (he = hv_iternext((HV *) This)) ) {
0d863452 3901 I32 key_len;
c445ea15 3902 char * const key = hv_iterkey(he, &key_len);
0d863452
RH		 3903
3904 ++ this_key_count;
3905
3906 if(!hv_exists(other_hv, key, key_len)) {
10edeb5d 3907 (void) hv_iterinit((HV *) This); /* reset iterator */
0d863452
RH		 3908 RETPUSHNO;
3909 }
3910 }
3911
3912 if (other_tied) {
3913 (void) hv_iterinit(other_hv);
3914 while ( hv_iternext(other_hv) )
3915 ++other_key_count;
3916 }
3917 else
3918 other_key_count = HvUSEDKEYS(other_hv);
3919
3920 if (this_key_count != other_key_count)
3921 RETPUSHNO;
3922 else
3923 RETPUSHYES;
3924 }
3925 else if (SM_OTHER_REF(PVAV)) {
10edeb5d 3926 AV * const other_av = (AV *) SvRV(Other);
c445ea15 3927 const I32 other_len = av_len(other_av) + 1;
0d863452
RH		 3928 I32 i;
3929
10edeb5d 3930 if (HvUSEDKEYS((HV *) This) != other_len)
0d863452
RH		 3931 RETPUSHNO;
3932
3933 for(i = 0; i < other_len; ++i) {
c445ea15 3934 SV ** const svp = av_fetch(other_av, i, FALSE);
0d863452
RH		 3935 char *key;
3936 STRLEN key_len;
3937
3938 if (!svp) /* ??? When can this happen? */
3939 RETPUSHNO;
3940
3941 key = SvPV(*svp, key_len);
10edeb5d 3942 if(!hv_exists((HV *) This, key, key_len))
0d863452
RH		 3943 RETPUSHNO;
3944 }
3945 RETPUSHYES;
3946 }
3947 else if (SM_OTHER_REGEX) {
c445ea15 3948 PMOP * const matcher = make_matcher(other_regex);
0d863452
RH		 3949 HE *he;
3950
10edeb5d
JH		 3951 (void) hv_iterinit((HV *) This);
3952 while ( (he = hv_iternext((HV *) This)) ) {
0d863452 3953 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
10edeb5d 3954 (void) hv_iterinit((HV *) This);
0d863452
RH		 3955 destroy_matcher(matcher);
3956 RETPUSHYES;
3957 }
3958 }
3959 destroy_matcher(matcher);
3960 RETPUSHNO;
3961 }
3962 else {
10edeb5d 3963 if (hv_exists_ent((HV *) This, Other, 0))
0d863452
RH		 3964 RETPUSHYES;
3965 else
3966 RETPUSHNO;
3967 }
3968 }
3969 else if (SM_REF(PVAV)) {
3970 if (SM_OTHER_REF(PVAV)) {
10edeb5d
JH		 3971 AV *other_av = (AV *) SvRV(Other);
3972 if (av_len((AV *) This) != av_len(other_av))
0d863452
RH		 3973 RETPUSHNO;
3974 else {
3975 I32 i;
c445ea15 3976 const I32 other_len = av_len(other_av);
0d863452 3977
a0714e2c 3978 if (NULL == seen_this) {
0d863452
RH		 3979 seen_this = newHV();
3980 (void) sv_2mortal((SV *) seen_this);
3981 }
a0714e2c 3982 if (NULL == seen_other) {
0d863452
RH		 3983 seen_this = newHV();
3984 (void) sv_2mortal((SV *) seen_other);
3985 }
3986 for(i = 0; i <= other_len; ++i) {
10edeb5d 3987 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
c445ea15
AL		 3988 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3989
0d863452
RH		 3990 if (!this_elem || !other_elem) {
3991 if (this_elem || other_elem)
3992 RETPUSHNO;
3993 }
3994 else if (SM_SEEN_THIS(*this_elem)
3995 || SM_SEEN_OTHER(*other_elem))
3996 {
3997 if (*this_elem != *other_elem)
3998 RETPUSHNO;
3999 }
4000 else {
4001 hv_store_ent(seen_this,
98f4023c 4002 sv_2mortal(newSViv(PTR2IV(*this_elem))),
0d863452
RH		 4003 &PL_sv_undef, 0);
4004 hv_store_ent(seen_other,
98f4023c 4005 sv_2mortal(newSViv(PTR2IV(*other_elem))),
0d863452
RH		 4006 &PL_sv_undef, 0);
4007 PUSHs(*this_elem);
4008 PUSHs(*other_elem);
4009
4010 PUTBACK;
4011 (void) do_smartmatch(seen_this, seen_other);
4012 SPAGAIN;
4013
4014 if (!SvTRUEx(POPs))
4015 RETPUSHNO;
4016 }
4017 }
4018 RETPUSHYES;
4019 }
4020 }
4021 else if (SM_OTHER_REGEX) {
c445ea15 4022 PMOP * const matcher = make_matcher(other_regex);
10edeb5d 4023 const I32 this_len = av_len((AV *) This);
0d863452 4024 I32 i;
0d863452
RH		 4025
4026 for(i = 0; i <= this_len; ++i) {
10edeb5d 4027 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
0d863452
RH		 4028 if (svp && matcher_matches_sv(matcher, *svp)) {
4029 destroy_matcher(matcher);
4030 RETPUSHYES;
4031 }
4032 }
4033 destroy_matcher(matcher);
4034 RETPUSHNO;
4035 }
10edeb5d 4036 else if (SvIOK(Other) || SvNOK(Other)) {
0d863452
RH		 4037 I32 i;
4038
10edeb5d
JH		 4039 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4040 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
0d863452
RH		 4041 if (!svp)
4042 continue;
4043
10edeb5d 4044 PUSHs(Other);
0d863452
RH		 4045 PUSHs(*svp);
4046 PUTBACK;
a98fe34d 4047 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
0d863452
RH		 4048 (void) pp_i_eq();
4049 else
4050 (void) pp_eq();
4051 SPAGAIN;
4052 if (SvTRUEx(POPs))
4053 RETPUSHYES;
4054 }
4055 RETPUSHNO;
4056 }
10edeb5d
JH		 4057 else if (SvPOK(Other)) {
4058 const I32 this_len = av_len((AV *) This);
0d863452 4059 I32 i;
0d863452
RH		 4060
4061 for(i = 0; i <= this_len; ++i) {
10edeb5d 4062 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
0d863452
RH		 4063 if (!svp)
4064 continue;
4065
10edeb5d 4066 PUSHs(Other);
0d863452
RH		 4067 PUSHs(*svp);
4068 PUTBACK;
4069 (void) pp_seq();
4070 SPAGAIN;
4071 if (SvTRUEx(POPs))
4072 RETPUSHYES;
4073 }
4074 RETPUSHNO;
4075 }
4076 }
4077 else if (!SvOK(d) || !SvOK(e)) {
4078 if (!SvOK(d) && !SvOK(e))
4079 RETPUSHYES;
4080 else
4081 RETPUSHNO;
4082 }
4083 else if (SM_REGEX) {
c445ea15 4084 PMOP * const matcher = make_matcher(this_regex);
0d863452
RH		 4085
4086 PUTBACK;
10edeb5d 4087 PUSHs(matcher_matches_sv(matcher, Other)
0d863452
RH		 4088 ? &PL_sv_yes
4089 : &PL_sv_no);
4090 destroy_matcher(matcher);
4091 RETURN;
4092 }
4093 else if (SM_REF(PVCV)) {
4094 I32 c;
4095 /* This must be a null-prototyped sub, because we
4096 already checked for the other kind. */
4097
4098 ENTER;
4099 SAVETMPS;
4100 PUSHMARK(SP);
4101 PUTBACK;
10edeb5d 4102 c = call_sv(This, G_SCALAR);
0d863452
RH		 4103 SPAGAIN;
4104 if (c == 0)
4105 PUSHs(&PL_sv_undef);
4106 else if (SvTEMP(TOPs))
df528165 4107 SvREFCNT_inc_void(TOPs);
0d863452
RH		 4108
4109 if (SM_OTHER_REF(PVCV)) {
4110 /* This one has to be null-proto'd too.
4111 Call both of 'em, and compare the results */
4112 PUSHMARK(SP);
10edeb5d 4113 c = call_sv(SvRV(Other), G_SCALAR);
0d863452
RH		 4114 SPAGAIN;
4115 if (c == 0)
4116 PUSHs(&PL_sv_undef);
4117 else if (SvTEMP(TOPs))
df528165 4118 SvREFCNT_inc_void(TOPs);
0d863452
RH		 4119 FREETMPS;
4120 LEAVE;
4121 PUTBACK;
4122 return pp_eq();
4123 }
4124
4125 FREETMPS;
4126 LEAVE;
4127 RETURN;
4128 }
10edeb5d
JH		 4129 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4130 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
0d863452 4131 {
10edeb5d 4132 if (SvPOK(Other) && !looks_like_number(Other)) {
0d863452
RH		 4133 /* String comparison */
4134 PUSHs(d); PUSHs(e);
4135 PUTBACK;
4136 return pp_seq();
4137 }
4138 /* Otherwise, numeric comparison */
4139 PUSHs(d); PUSHs(e);
4140 PUTBACK;
a98fe34d 4141 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
0d863452
RH		 4142 (void) pp_i_eq();
4143 else
4144 (void) pp_eq();
4145 SPAGAIN;
4146 if (SvTRUEx(POPs))
4147 RETPUSHYES;
4148 else
4149 RETPUSHNO;
4150 }
4151
4152 /* As a last resort, use string comparison */
4153 PUSHs(d); PUSHs(e);
4154 PUTBACK;
4155 return pp_seq();
4156}
4157
4158PP(pp_enterwhen)
4159{
4160 dVAR; dSP;
4161 register PERL_CONTEXT *cx;
4162 const I32 gimme = GIMME_V;
4163
4164 /* This is essentially an optimization: if the match
4165 fails, we don't want to push a context and then
4166 pop it again right away, so we skip straight
4167 to the op that follows the leavewhen.
4168 */
4169 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4170 return cLOGOP->op_other->op_next;
4171
4172 ENTER;
4173 SAVETMPS;
4174
4175 PUSHBLOCK(cx, CXt_WHEN, SP);
4176 PUSHWHEN(cx);
4177
4178 RETURN;
4179}
4180
4181PP(pp_leavewhen)
4182{
4183 dVAR; dSP;
4184 register PERL_CONTEXT *cx;
4185 I32 gimme;
4186 SV **newsp;
4187 PMOP *newpm;
4188
4189 POPBLOCK(cx,newpm);
4190 assert(CxTYPE(cx) == CXt_WHEN);
4191
4192 SP = newsp;
4193 PUTBACK;
4194
4195 PL_curpm = newpm; /* pop $1 et al */
4196
4197 LEAVE;
4198 return NORMAL;
4199}
4200
4201PP(pp_continue)
4202{
4203 dVAR;
4204 I32 cxix;
4205 register PERL_CONTEXT *cx;
4206 I32 inner;
4207
4208 cxix = dopoptowhen(cxstack_ix);
4209 if (cxix < 0)
4210 DIE(aTHX_ "Can't \"continue\" outside a when block");
4211 if (cxix < cxstack_ix)
4212 dounwind(cxix);
4213
4214 /* clear off anything above the scope we're re-entering */
4215 inner = PL_scopestack_ix;
4216 TOPBLOCK(cx);
4217 if (PL_scopestack_ix < inner)
4218 leave_scope(PL_scopestack[PL_scopestack_ix]);
4219 PL_curcop = cx->blk_oldcop;
4220 return cx->blk_givwhen.leave_op;
4221}
4222
4223PP(pp_break)
4224{
4225 dVAR;
4226 I32 cxix;
4227 register PERL_CONTEXT *cx;
4228 I32 inner;
4229
4230 cxix = dopoptogiven(cxstack_ix);
4231 if (cxix < 0) {
4232 if (PL_op->op_flags & OPf_SPECIAL)
4233 DIE(aTHX_ "Can't use when() outside a topicalizer");
4234 else
4235 DIE(aTHX_ "Can't \"break\" outside a given block");
4236 }
4237 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4238 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4239
4240 if (cxix < cxstack_ix)
4241 dounwind(cxix);
4242
4243 /* clear off anything above the scope we're re-entering */
4244 inner = PL_scopestack_ix;
4245 TOPBLOCK(cx);
4246 if (PL_scopestack_ix < inner)
4247 leave_scope(PL_scopestack[PL_scopestack_ix]);
4248 PL_curcop = cx->blk_oldcop;
4249
4250 if (CxFOREACH(cx))
022eaa24 4251 return CX_LOOP_NEXTOP_GET(cx);
0d863452
RH		 4252 else
4253 return cx->blk_givwhen.leave_op;
4254}
4255
a1b95068 4256STATIC OP *
cea2e8a9 4257S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 4258{
4259 STRLEN len;
4260 register char *s = SvPV_force(sv, len);
c445ea15
AL		 4261 register char * const send = s + len;
4262 register char *base = NULL;
a0d0e21e 4263 register I32 skipspaces = 0;
9c5ffd7c
JH		 4264 bool noblank = FALSE;
4265 bool repeat = FALSE;
a0d0e21e 4266 bool postspace = FALSE;
dea28490
JJ		 4267 U32 *fops;
4268 register U32 *fpc;
cbbf8932 4269 U32 *linepc = NULL;
a0d0e21e
LW		 4270 register I32 arg;
4271 bool ischop;
a1b95068
WL		 4272 bool unchopnum = FALSE;
4273 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
a0d0e21e 4274
55497cff 4275 if (len == 0)
cea2e8a9 4276 Perl_croak(aTHX_ "Null picture in formline");
ac27b0f5 4277
815f25c6
DM		 4278 /* estimate the buffer size needed */
4279 for (base = s; s <= send; s++) {
a1b95068 4280 if (*s == '\n' || *s == '@' || *s == '^')
815f25c6
DM		 4281 maxops += 10;
4282 }
4283 s = base;
c445ea15 4284 base = NULL;
815f25c6 4285
a02a5408 4286 Newx(fops, maxops, U32);
a0d0e21e
LW		 4287 fpc = fops;
4288
4289 if (s < send) {
4290 linepc = fpc;
4291 *fpc++ = FF_LINEMARK;
4292 noblank = repeat = FALSE;
4293 base = s;
4294 }
4295
4296 while (s <= send) {
4297 switch (*s++) {
4298 default:
4299 skipspaces = 0;
4300 continue;
4301
4302 case '~':
4303 if (*s == '~') {
4304 repeat = TRUE;
4305 *s = ' ';
4306 }
4307 noblank = TRUE;
4308 s[-1] = ' ';
4309 /* FALL THROUGH */
4310 case ' ': case '\t':
4311 skipspaces++;
4312 continue;
a1b95068
WL		 4313 case 0:
4314 if (s < send) {
4315 skipspaces = 0;
4316 continue;
4317 } /* else FALL THROUGH */
4318 case '\n':
a0d0e21e
LW		 4319 arg = s - base;
4320 skipspaces++;
4321 arg -= skipspaces;
4322 if (arg) {
5f05dabc 4323 if (postspace)
a0d0e21e 4324 *fpc++ = FF_SPACE;
a0d0e21e 4325 *fpc++ = FF_LITERAL;
eb160463 4326 *fpc++ = (U16)arg;
a0d0e21e 4327 }
5f05dabc 4328 postspace = FALSE;
a0d0e21e
LW		 4329 if (s <= send)
4330 skipspaces--;
4331 if (skipspaces) {
4332 *fpc++ = FF_SKIP;
eb160463 4333 *fpc++ = (U16)skipspaces;
a0d0e21e
LW		 4334 }
4335 skipspaces = 0;
4336 if (s <= send)
4337 *fpc++ = FF_NEWLINE;
4338 if (noblank) {
4339 *fpc++ = FF_BLANK;
4340 if (repeat)
4341 arg = fpc - linepc + 1;
4342 else
4343 arg = 0;
eb160463 4344 *fpc++ = (U16)arg;
a0d0e21e
LW		 4345 }
4346 if (s < send) {
4347 linepc = fpc;
4348 *fpc++ = FF_LINEMARK;
4349 noblank = repeat = FALSE;
4350 base = s;
4351 }
4352 else
4353 s++;
4354 continue;
4355
4356 case '@':
4357 case '^':
4358 ischop = s[-1] == '^';
4359
4360 if (postspace) {
4361 *fpc++ = FF_SPACE;
4362 postspace = FALSE;
4363 }
4364 arg = (s - base) - 1;
4365 if (arg) {
4366 *fpc++ = FF_LITERAL;
eb160463 4367 *fpc++ = (U16)arg;
a0d0e21e
LW		 4368 }
4369
4370 base = s - 1;
4371 *fpc++ = FF_FETCH;
4372 if (*s == '*') {
4373 s++;
a1b95068
WL		 4374 *fpc++ = 2; /* skip the @* or ^* */
4375 if (ischop) {
4376 *fpc++ = FF_LINESNGL;
4377 *fpc++ = FF_CHOP;
4378 } else
4379 *fpc++ = FF_LINEGLOB;
a0d0e21e
LW		 4380 }
4381 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4382 arg = ischop ? 512 : 0;
4383 base = s - 1;
4384 while (*s == '#')
4385 s++;
4386 if (*s == '.') {
06b5626a 4387 const char * const f = ++s;
a0d0e21e
LW		 4388 while (*s == '#')
4389 s++;
4390 arg |= 256 + (s - f);
4391 }
4392 *fpc++ = s - base; /* fieldsize for FETCH */
4393 *fpc++ = FF_DECIMAL;
eb160463 4394 *fpc++ = (U16)arg;
a1b95068 4395 unchopnum |= ! ischop;
784707d5
JP		 4396 }
4397 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4398 arg = ischop ? 512 : 0;
4399 base = s - 1;
4400 s++; /* skip the '0' first */
4401 while (*s == '#')
4402 s++;
4403 if (*s == '.') {
06b5626a 4404 const char * const f = ++s;
784707d5
JP		 4405 while (*s == '#')
4406 s++;
4407 arg |= 256 + (s - f);
4408 }
4409 *fpc++ = s - base; /* fieldsize for FETCH */
4410 *fpc++ = FF_0DECIMAL;
eb160463 4411 *fpc++ = (U16)arg;
a1b95068 4412 unchopnum |= ! ischop;
a0d0e21e
LW		 4413 }
4414 else {
4415 I32 prespace = 0;
4416 bool ismore = FALSE;
4417
4418 if (*s == '>') {
4419 while (*++s == '>') ;
4420 prespace = FF_SPACE;
4421 }
4422 else if (*s == '|') {
4423 while (*++s == '|') ;
4424 prespace = FF_HALFSPACE;
4425 postspace = TRUE;
4426 }
4427 else {
4428 if (*s == '<')
4429 while (*++s == '<') ;
4430 postspace = TRUE;
4431 }
4432 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4433 s += 3;
4434 ismore = TRUE;
4435 }
4436 *fpc++ = s - base; /* fieldsize for FETCH */
4437
4438 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4439
4440 if (prespace)
eb160463 4441 *fpc++ = (U16)prespace;
a0d0e21e
LW		 4442 *fpc++ = FF_ITEM;
4443 if (ismore)
4444 *fpc++ = FF_MORE;
4445 if (ischop)
4446 *fpc++ = FF_CHOP;
4447 }
4448 base = s;
4449 skipspaces = 0;
4450 continue;
4451 }
4452 }
4453 *fpc++ = FF_END;
4454
815f25c6 4455 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
a0d0e21e
LW		 4456 arg = fpc - fops;
4457 { /* need to jump to the next word */
4458 int z;
4459 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
dea28490 4460 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
a0d0e21e
LW		 4461 s = SvPVX(sv) + SvCUR(sv) + z;
4462 }
dea28490 4463 Copy(fops, s, arg, U32);
a0d0e21e 4464 Safefree(fops);
c445ea15 4465 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
a0d0e21e 4466 SvCOMPILED_on(sv);
a1b95068 4467
bfed75c6 4468 if (unchopnum && repeat)
a1b95068
WL		 4469 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4470 return 0;
4471}
4472
4473
4474STATIC bool
4475S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4476{
4477 /* Can value be printed in fldsize chars, using %*.*f ? */
4478 NV pwr = 1;
4479 NV eps = 0.5;
4480 bool res = FALSE;
4481 int intsize = fldsize - (value < 0 ? 1 : 0);
4482
4483 if (frcsize & 256)
4484 intsize--;
4485 frcsize &= 255;
4486 intsize -= frcsize;
4487
4488 while (intsize--) pwr *= 10.0;
4489 while (frcsize--) eps /= 10.0;
4490
4491 if( value >= 0 ){
4492 if (value + eps >= pwr)
4493 res = TRUE;
4494 } else {
4495 if (value - eps <= -pwr)
4496 res = TRUE;
4497 }
4498 return res;
a0d0e21e 4499}
4e35701f 4500
bbed91b5 4501static I32
0bd48802 4502S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
bbed91b5 4503{
27da23d5 4504 dVAR;
0bd48802 4505 SV * const datasv = FILTER_DATA(idx);
504618e9 4506 const int filter_has_file = IoLINES(datasv);
0bd48802
AL		 4507 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4508 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
941a98a0 4509 int status = 0;
ec0b63d7 4510 SV *upstream;
941a98a0 4511 STRLEN got_len;
95b63a38 4512 const char *got_p = NULL;
941a98a0 4513 const char *prune_from = NULL;
34113e50 4514 bool read_from_cache = FALSE;
bb7a0f54
MHM		 4515 STRLEN umaxlen;
4516
4517 assert(maxlen >= 0);
4518 umaxlen = maxlen;
5675696b 4519
bbed91b5
KF		 4520 /* I was having segfault trouble under Linux 2.2.5 after a
4521 parse error occured. (Had to hack around it with a test
4522 for PL_error_count == 0.) Solaris doesn't segfault --
4523 not sure where the trouble is yet. XXX */
4524
941a98a0 4525 if (IoFMT_GV(datasv)) {
937b367d
NC		 4526 SV *const cache = (SV *)IoFMT_GV(datasv);
4527 if (SvOK(cache)) {
4528 STRLEN cache_len;
4529 const char *cache_p = SvPV(cache, cache_len);
941a98a0
NC		 4530 STRLEN take = 0;
4531
bb7a0f54 4532 if (umaxlen) {
941a98a0
NC		 4533 /* Running in block mode and we have some cached data already.
4534 */
bb7a0f54 4535 if (cache_len >= umaxlen) {
941a98a0
NC		 4536 /* In fact, so much data we don't even need to call
4537 filter_read. */
bb7a0f54 4538 take = umaxlen;
941a98a0
NC		 4539 }
4540 } else {
10edeb5d
JH		 4541 const char *const first_nl =
4542 (const char *)memchr(cache_p, '\n', cache_len);
941a98a0
NC		 4543 if (first_nl) {
4544 take = first_nl + 1 - cache_p;
4545 }
4546 }
4547 if (take) {
4548 sv_catpvn(buf_sv, cache_p, take);
4549 sv_chop(cache, cache_p + take);
937b367d
NC		 4550 /* Definately not EOF */
4551 return 1;
4552 }
941a98a0 4553
937b367d 4554 sv_catsv(buf_sv, cache);
bb7a0f54
MHM		 4555 if (umaxlen) {
4556 umaxlen -= cache_len;
941a98a0 4557 }
937b367d 4558 SvOK_off(cache);
34113e50 4559 read_from_cache = TRUE;
937b367d
NC		 4560 }
4561 }
ec0b63d7 4562
34113e50
NC		 4563 /* Filter API says that the filter appends to the contents of the buffer.
4564 Usually the buffer is "", so the details don't matter. But if it's not,
4565 then clearly what it contains is already filtered by this filter, so we
4566 don't want to pass it in a second time.
4567 I'm going to use a mortal in case the upstream filter croaks. */
ec0b63d7
NC		 4568 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4569 ? sv_newmortal() : buf_sv;
4570 SvUPGRADE(upstream, SVt_PV);
937b367d 4571
bbed91b5 4572 if (filter_has_file) {
67e70b33 4573 status = FILTER_READ(idx+1, upstream, 0);
bbed91b5
KF		 4574 }
4575
34113e50 4576 if (filter_sub && status >= 0) {
39644a26 4577 dSP;
bbed91b5
KF		 4578 int count;
4579
4580 ENTER;
4581 SAVE_DEFSV;
4582 SAVETMPS;
4583 EXTEND(SP, 2);
4584
5675696b 4585 DEFSV = upstream;
bbed91b5 4586 PUSHMARK(SP);
67e70b33 4587 PUSHs(sv_2mortal(newSViv(0)));
bbed91b5
KF		 4588 if (filter_state) {
4589 PUSHs(filter_state);
4590 }
4591 PUTBACK;
4592 count = call_sv(filter_sub, G_SCALAR);
4593 SPAGAIN;
4594
4595 if (count > 0) {
4596 SV *out = POPs;
4597 if (SvOK(out)) {
941a98a0 4598 status = SvIV(out);
bbed91b5
KF		 4599 }
4600 }
4601
4602 PUTBACK;
4603 FREETMPS;
4604 LEAVE;
4605 }
4606
941a98a0
NC		 4607 if(SvOK(upstream)) {
4608 got_p = SvPV(upstream, got_len);
bb7a0f54
MHM		 4609 if (umaxlen) {
4610 if (got_len > umaxlen) {
4611 prune_from = got_p + umaxlen;
937b367d 4612 }
941a98a0 4613 } else {
10edeb5d
JH		 4614 const char *const first_nl =
4615 (const char *)memchr(got_p, '\n', got_len);
941a98a0
NC		 4616 if (first_nl && first_nl + 1 < got_p + got_len) {
4617 /* There's a second line here... */
4618 prune_from = first_nl + 1;
937b367d 4619 }
937b367d
NC		 4620 }
4621 }
941a98a0
NC		 4622 if (prune_from) {
4623 /* Oh. Too long. Stuff some in our cache. */
4624 STRLEN cached_len = got_p + got_len - prune_from;
4625 SV *cache = (SV *)IoFMT_GV(datasv);
4626
4627 if (!cache) {
bb7a0f54 4628 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
941a98a0
NC		 4629 } else if (SvOK(cache)) {
4630 /* Cache should be empty. */
4631 assert(!SvCUR(cache));
4632 }
4633
4634 sv_setpvn(cache, prune_from, cached_len);
4635 /* If you ask for block mode, you may well split UTF-8 characters.
4636 "If it breaks, you get to keep both parts"
4637 (Your code is broken if you don't put them back together again
4638 before something notices.) */
4639 if (SvUTF8(upstream)) {
4640 SvUTF8_on(cache);
4641 }
4642 SvCUR_set(upstream, got_len - cached_len);
4643 /* Can't yet be EOF */
4644 if (status == 0)
4645 status = 1;
4646 }
937b367d 4647
34113e50
NC		 4648 /* If they are at EOF but buf_sv has something in it, then they may never
4649 have touched the SV upstream, so it may be undefined. If we naively
4650 concatenate it then we get a warning about use of uninitialised value.
4651 */
4652 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
937b367d
NC		 4653 sv_catsv(buf_sv, upstream);
4654 }
4655
941a98a0 4656 if (status <= 0) {
bbed91b5 4657 IoLINES(datasv) = 0;
937b367d 4658 SvREFCNT_dec(IoFMT_GV(datasv));
bbed91b5
KF		 4659 if (filter_state) {
4660 SvREFCNT_dec(filter_state);
a0714e2c 4661 IoTOP_GV(datasv) = NULL;
bbed91b5
KF		 4662 }
4663 if (filter_sub) {
4664 SvREFCNT_dec(filter_sub);
a0714e2c 4665 IoBOTTOM_GV(datasv) = NULL;
bbed91b5 4666 }
0bd48802 4667 filter_del(S_run_user_filter);
bbed91b5 4668 }
34113e50
NC		 4669 if (status == 0 && read_from_cache) {
4670 /* If we read some data from the cache (and by getting here it implies
4671 that we emptied the cache) then we aren't yet at EOF, and mustn't
4672 report that to our caller. */
4673 return 1;
4674 }
941a98a0 4675 return status;
bbed91b5 4676}
84d4ea48 4677
be4b629d
CN		 4678/* perhaps someone can come up with a better name for
4679 this? it is not really "absolute", per se ... */
cf42f822 4680static bool
5f66b61c 4681S_path_is_absolute(const char *name)
be4b629d
CN		 4682{
4683 if (PERL_FILE_IS_ABSOLUTE(name)
4684#ifdef MACOS_TRADITIONAL
0bd48802 4685 || (*name == ':')
be4b629d
CN		 4686#else
4687 || (*name == '.' && (name[1] == '/' ||
0bd48802 4688 (name[1] == '.' && name[2] == '/')))
be4b629d 4689#endif
0bd48802 4690 )
be4b629d
CN		 4691 {
4692 return TRUE;
4693 }
4694 else
4695 return FALSE;
4696}
241d1a3b
NC		 4697
4698/*
4699 * Local variables:
4700 * c-indentation-style: bsd
4701 * c-basic-offset: 4
4702 * indent-tabs-mode: t
4703 * End:
4704 *
37442d52
RGS		 4705 * ex: set ts=8 sts=4 sw=4 noet:
4706 */
Unnamed repository; edit this file 'description' to name the repository.