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