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