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