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
Skip unportable test on VMS
[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))) {
c445ea15 287 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
14befaf4 288 mg = mg_find(sv, PERL_MAGIC_regex_global);
084916e3
JH		 289 }
290 i = m - orig;
291 if (DO_UTF8(sv))
292 sv_pos_b2u(sv, &i);
293 mg->mg_len = i;
294 }
988e6e7e 295 if (old != rx)
454f1e26 296 (void)ReREFCNT_inc(rx);
d9f97599
GS		 297 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
298 rxres_save(&cx->sb_rxres, rx);
a0d0e21e
LW		 299 RETURNOP(pm->op_pmreplstart);
300}
301
c90c0ff4 302void
864dbfa3 303Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 304{
305 UV *p = (UV*)*rsp;
306 U32 i;
96a5add6 307 PERL_UNUSED_CONTEXT;
c90c0ff4 308
d9f97599 309 if (!p || p[1] < rx->nparens) {
f8c7b90f 310#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 311 i = 7 + rx->nparens * 2;
312#else
d9f97599 313 i = 6 + rx->nparens * 2;
ed252734 314#endif
c90c0ff4 315 if (!p)
a02a5408 316 Newx(p, i, UV);
c90c0ff4 317 else
318 Renew(p, i, UV);
319 *rsp = (void*)p;
320 }
321
c445ea15 322 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
cf93c79d 323 RX_MATCH_COPIED_off(rx);
c90c0ff4 324
f8c7b90f 325#ifdef PERL_OLD_COPY_ON_WRITE
ed252734 326 *p++ = PTR2UV(rx->saved_copy);
c445ea15 327 rx->saved_copy = NULL;
ed252734
NC		 328#endif
329
d9f97599 330 *p++ = rx->nparens;
c90c0ff4 331
56431972 332 *p++ = PTR2UV(rx->subbeg);
cf93c79d 333 *p++ = (UV)rx->sublen;
d9f97599
GS		 334 for (i = 0; i <= rx->nparens; ++i) {
335 *p++ = (UV)rx->startp[i];
336 *p++ = (UV)rx->endp[i];
c90c0ff4 337 }
338}
339
340void
864dbfa3 341Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 342{
343 UV *p = (UV*)*rsp;
344 U32 i;
96a5add6 345 PERL_UNUSED_CONTEXT;
c90c0ff4 346
ed252734 347 RX_MATCH_COPY_FREE(rx);
cf93c79d 348 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4 349 *p++ = 0;
350
f8c7b90f 351#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 352 if (rx->saved_copy)
353 SvREFCNT_dec (rx->saved_copy);
354 rx->saved_copy = INT2PTR(SV*,*p);
355 *p++ = 0;
356#endif
357
d9f97599 358 rx->nparens = *p++;
c90c0ff4 359
56431972 360 rx->subbeg = INT2PTR(char*,*p++);
cf93c79d 361 rx->sublen = (I32)(*p++);
d9f97599 362 for (i = 0; i <= rx->nparens; ++i) {
cf93c79d
IZ		 363 rx->startp[i] = (I32)(*p++);
364 rx->endp[i] = (I32)(*p++);
c90c0ff4 365 }
366}
367
368void
864dbfa3 369Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 370{
44f8325f 371 UV * const p = (UV*)*rsp;
96a5add6 372 PERL_UNUSED_CONTEXT;
c90c0ff4 373
374 if (p) {
94010e71
NC		 375#ifdef PERL_POISON
376 void *tmp = INT2PTR(char*,*p);
377 Safefree(tmp);
378 if (*p)
379 Poison(*p, 1, sizeof(*p));
380#else
56431972 381 Safefree(INT2PTR(char*,*p));
94010e71 382#endif
f8c7b90f 383#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 384 if (p[1]) {
385 SvREFCNT_dec (INT2PTR(SV*,p[1]));
386 }
387#endif
c90c0ff4 388 Safefree(p);
4608196e 389 *rsp = NULL;
c90c0ff4 390 }
391}
392
a0d0e21e
LW		 393PP(pp_formline)
394{
97aff369 395 dVAR; dSP; dMARK; dORIGMARK;
823a54a3 396 register SV * const tmpForm = *++MARK;
dea28490 397 register U32 *fpc;
a0d0e21e 398 register char *t;
245d4a47 399 const char *f;
a0d0e21e 400 register I32 arg;
c445ea15
AL		 401 register SV *sv = NULL;
402 const char *item = NULL;
9c5ffd7c
JH		 403 I32 itemsize = 0;
404 I32 fieldsize = 0;
a0d0e21e 405 I32 lines = 0;
c445ea15
AL		 406 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
407 const char *chophere = NULL;
408 char *linemark = NULL;
65202027 409 NV value;
9c5ffd7c 410 bool gotsome = FALSE;
a0d0e21e 411 STRLEN len;
823a54a3 412 const STRLEN fudge = SvPOK(tmpForm)
24c89738 413 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
1bd51a4c
IH		 414 bool item_is_utf8 = FALSE;
415 bool targ_is_utf8 = FALSE;
c445ea15 416 SV * nsv = NULL;
cbbf8932 417 OP * parseres = NULL;
bfed75c6 418 const char *fmt;
a1b95068 419 bool oneline;
a0d0e21e 420
76e3520e 421 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445b3f51
GS		 422 if (SvREADONLY(tmpForm)) {
423 SvREADONLY_off(tmpForm);
a1b95068 424 parseres = doparseform(tmpForm);
445b3f51
GS		 425 SvREADONLY_on(tmpForm);
426 }
427 else
a1b95068
WL		 428 parseres = doparseform(tmpForm);
429 if (parseres)
430 return parseres;
a0d0e21e 431 }
3280af22 432 SvPV_force(PL_formtarget, len);
1bd51a4c
IH		 433 if (DO_UTF8(PL_formtarget))
434 targ_is_utf8 = TRUE;
a0ed51b3 435 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 436 t += len;
245d4a47 437 f = SvPV_const(tmpForm, len);
a0d0e21e 438 /* need to jump to the next word */
245d4a47 439 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
a0d0e21e
LW		 440
441 for (;;) {
442 DEBUG_f( {
bfed75c6 443 const char *name = "???";
a0d0e21e
LW		 444 arg = -1;
445 switch (*fpc) {
446 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
447 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
448 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
449 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
450 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
451
452 case FF_CHECKNL: name = "CHECKNL"; break;
453 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
454 case FF_SPACE: name = "SPACE"; break;
455 case FF_HALFSPACE: name = "HALFSPACE"; break;
456 case FF_ITEM: name = "ITEM"; break;
457 case FF_CHOP: name = "CHOP"; break;
458 case FF_LINEGLOB: name = "LINEGLOB"; break;
459 case FF_NEWLINE: name = "NEWLINE"; break;
460 case FF_MORE: name = "MORE"; break;
461 case FF_LINEMARK: name = "LINEMARK"; break;
462 case FF_END: name = "END"; break;
bfed75c6 463 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 464 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW		 465 }
466 if (arg >= 0)
bf49b057 467 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 468 else
bf49b057 469 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 470 } );
a0d0e21e
LW		 471 switch (*fpc++) {
472 case FF_LINEMARK:
473 linemark = t;
a0d0e21e
LW		 474 lines++;
475 gotsome = FALSE;
476 break;
477
478 case FF_LITERAL:
479 arg = *fpc++;
1bd51a4c 480 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
b15aece3 481 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
78da4d13
JH		 482 *t = '\0';
483 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
484 t = SvEND(PL_formtarget);
1bd51a4c
IH		 485 break;
486 }
487 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
b15aece3 488 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 489 *t = '\0';
490 sv_utf8_upgrade(PL_formtarget);
491 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
492 t = SvEND(PL_formtarget);
493 targ_is_utf8 = TRUE;
494 }
a0d0e21e
LW		 495 while (arg--)
496 *t++ = *f++;
497 break;
498
499 case FF_SKIP:
500 f += *fpc++;
501 break;
502
503 case FF_FETCH:
504 arg = *fpc++;
505 f += arg;
506 fieldsize = arg;
507
508 if (MARK < SP)
509 sv = *++MARK;
510 else {
3280af22 511 sv = &PL_sv_no;
599cee73 512 if (ckWARN(WARN_SYNTAX))
9014280d 513 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e
LW		 514 }
515 break;
516
517 case FF_CHECKNL:
5a34cab7
NC		 518 {
519 const char *send;
520 const char *s = item = SvPV_const(sv, len);
521 itemsize = len;
522 if (DO_UTF8(sv)) {
523 itemsize = sv_len_utf8(sv);
524 if (itemsize != (I32)len) {
525 I32 itembytes;
526 if (itemsize > fieldsize) {
527 itemsize = fieldsize;
528 itembytes = itemsize;
529 sv_pos_u2b(sv, &itembytes, 0);
530 }
531 else
532 itembytes = len;
533 send = chophere = s + itembytes;
534 while (s < send) {
535 if (*s & ~31)
536 gotsome = TRUE;
537 else if (*s == '\n')
538 break;
539 s++;
540 }
541 item_is_utf8 = TRUE;
542 itemsize = s - item;
543 sv_pos_b2u(sv, &itemsize);
544 break;
a0ed51b3 545 }
a0ed51b3 546 }
5a34cab7
NC		 547 item_is_utf8 = FALSE;
548 if (itemsize > fieldsize)
549 itemsize = fieldsize;
550 send = chophere = s + itemsize;
551 while (s < send) {
552 if (*s & ~31)
553 gotsome = TRUE;
554 else if (*s == '\n')
555 break;
556 s++;
557 }
558 itemsize = s - item;
559 break;
a0ed51b3 560 }
a0d0e21e
LW		 561
562 case FF_CHECKCHOP:
5a34cab7
NC		 563 {
564 const char *s = item = SvPV_const(sv, len);
565 itemsize = len;
566 if (DO_UTF8(sv)) {
567 itemsize = sv_len_utf8(sv);
568 if (itemsize != (I32)len) {
569 I32 itembytes;
570 if (itemsize <= fieldsize) {
571 const char *send = chophere = s + itemsize;
572 while (s < send) {
573 if (*s == '\r') {
574 itemsize = s - item;
a0ed51b3 575 chophere = s;
a0ed51b3 576 break;
5a34cab7
NC		 577 }
578 if (*s++ & ~31)
a0ed51b3 579 gotsome = TRUE;
a0ed51b3 580 }
a0ed51b3 581 }
5a34cab7
NC		 582 else {
583 const char *send;
584 itemsize = fieldsize;
585 itembytes = itemsize;
586 sv_pos_u2b(sv, &itembytes, 0);
587 send = chophere = s + itembytes;
588 while (s < send || (s == send && isSPACE(*s))) {
589 if (isSPACE(*s)) {
590 if (chopspace)
591 chophere = s;
592 if (*s == '\r')
593 break;
594 }
595 else {
596 if (*s & ~31)
597 gotsome = TRUE;
598 if (strchr(PL_chopset, *s))
599 chophere = s + 1;
600 }
601 s++;
602 }
603 itemsize = chophere - item;
604 sv_pos_b2u(sv, &itemsize);
605 }
606 item_is_utf8 = TRUE;
a0d0e21e
LW		 607 break;
608 }
a0d0e21e 609 }
5a34cab7
NC		 610 item_is_utf8 = FALSE;
611 if (itemsize <= fieldsize) {
612 const char *const send = chophere = s + itemsize;
613 while (s < send) {
614 if (*s == '\r') {
615 itemsize = s - item;
a0d0e21e 616 chophere = s;
a0d0e21e 617 break;
5a34cab7
NC		 618 }
619 if (*s++ & ~31)
a0d0e21e 620 gotsome = TRUE;
a0d0e21e 621 }
a0d0e21e 622 }
5a34cab7
NC		 623 else {
624 const char *send;
625 itemsize = fieldsize;
626 send = chophere = s + itemsize;
627 while (s < send || (s == send && isSPACE(*s))) {
628 if (isSPACE(*s)) {
629 if (chopspace)
630 chophere = s;
631 if (*s == '\r')
632 break;
633 }
634 else {
635 if (*s & ~31)
636 gotsome = TRUE;
637 if (strchr(PL_chopset, *s))
638 chophere = s + 1;
639 }
640 s++;
641 }
642 itemsize = chophere - item;
643 }
644 break;
a0d0e21e 645 }
a0d0e21e
LW		 646
647 case FF_SPACE:
648 arg = fieldsize - itemsize;
649 if (arg) {
650 fieldsize -= arg;
651 while (arg-- > 0)
652 *t++ = ' ';
653 }
654 break;
655
656 case FF_HALFSPACE:
657 arg = fieldsize - itemsize;
658 if (arg) {
659 arg /= 2;
660 fieldsize -= arg;
661 while (arg-- > 0)
662 *t++ = ' ';
663 }
664 break;
665
666 case FF_ITEM:
5a34cab7
NC		 667 {
668 const char *s = item;
669 arg = itemsize;
670 if (item_is_utf8) {
671 if (!targ_is_utf8) {
672 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
673 *t = '\0';
674 sv_utf8_upgrade(PL_formtarget);
675 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
676 t = SvEND(PL_formtarget);
677 targ_is_utf8 = TRUE;
a0ed51b3 678 }
5a34cab7
NC		 679 while (arg--) {
680 if (UTF8_IS_CONTINUED(*s)) {
681 STRLEN skip = UTF8SKIP(s);
682 switch (skip) {
683 default:
684 Move(s,t,skip,char);
685 s += skip;
686 t += skip;
687 break;
688 case 7: *t++ = *s++;
689 case 6: *t++ = *s++;
690 case 5: *t++ = *s++;
691 case 4: *t++ = *s++;
692 case 3: *t++ = *s++;
693 case 2: *t++ = *s++;
694 case 1: *t++ = *s++;
695 }
696 }
697 else {
698 if ( !((*t++ = *s++) & ~31) )
699 t[-1] = ' ';
700 }
a0ed51b3 701 }
5a34cab7 702 break;
a0ed51b3 703 }
5a34cab7
NC		 704 if (targ_is_utf8 && !item_is_utf8) {
705 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
706 *t = '\0';
707 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
708 for (; t < SvEND(PL_formtarget); t++) {
78da4d13 709#ifdef EBCDIC
901017d6 710 const int ch = *t;
5a34cab7 711 if (iscntrl(ch))
78da4d13 712#else
5a34cab7 713 if (!(*t & ~31))
78da4d13 714#endif
5a34cab7
NC		 715 *t = ' ';
716 }
717 break;
78da4d13 718 }
5a34cab7 719 while (arg--) {
9d116dd7 720#ifdef EBCDIC
901017d6 721 const int ch = *t++ = *s++;
5a34cab7 722 if (iscntrl(ch))
a0d0e21e 723#else
5a34cab7 724 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 725#endif
5a34cab7
NC		 726 t[-1] = ' ';
727 }
728 break;
a0d0e21e 729 }
a0d0e21e
LW		 730
731 case FF_CHOP:
5a34cab7
NC		 732 {
733 const char *s = chophere;
734 if (chopspace) {
af68e756 735 while (isSPACE(*s))
5a34cab7
NC		 736 s++;
737 }
738 sv_chop(sv,s);
739 SvSETMAGIC(sv);
740 break;
a0d0e21e 741 }
a0d0e21e 742
a1b95068
WL		 743 case FF_LINESNGL:
744 chopspace = 0;
745 oneline = TRUE;
746 goto ff_line;
a0d0e21e 747 case FF_LINEGLOB:
a1b95068
WL		 748 oneline = FALSE;
749 ff_line:
5a34cab7
NC		 750 {
751 const char *s = item = SvPV_const(sv, len);
752 itemsize = len;
753 if ((item_is_utf8 = DO_UTF8(sv)))
754 itemsize = sv_len_utf8(sv);
755 if (itemsize) {
756 bool chopped = FALSE;
757 const char *const send = s + len;
758 gotsome = TRUE;
759 chophere = s + itemsize;
760 while (s < send) {
761 if (*s++ == '\n') {
762 if (oneline) {
763 chopped = TRUE;
764 chophere = s;
765 break;
766 } else {
767 if (s == send) {
768 itemsize--;
769 chopped = TRUE;
770 } else
771 lines++;
772 }
1bd51a4c 773 }
a0d0e21e 774 }
5a34cab7
NC		 775 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
776 if (targ_is_utf8)
777 SvUTF8_on(PL_formtarget);
778 if (oneline) {
779 SvCUR_set(sv, chophere - item);
780 sv_catsv(PL_formtarget, sv);
781 SvCUR_set(sv, itemsize);
782 } else
783 sv_catsv(PL_formtarget, sv);
784 if (chopped)
785 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
786 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
787 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
788 if (item_is_utf8)
789 targ_is_utf8 = TRUE;
a0d0e21e 790 }
5a34cab7 791 break;
a0d0e21e 792 }
a0d0e21e 793
a1b95068
WL		 794 case FF_0DECIMAL:
795 arg = *fpc++;
796#if defined(USE_LONG_DOUBLE)
797 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
798#else
799 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
800#endif
801 goto ff_dec;
a0d0e21e 802 case FF_DECIMAL:
a0d0e21e 803 arg = *fpc++;
65202027 804#if defined(USE_LONG_DOUBLE)
a1b95068 805 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
65202027 806#else
a1b95068 807 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
65202027 808#endif
a1b95068 809 ff_dec:
784707d5
JP		 810 /* If the field is marked with ^ and the value is undefined,
811 blank it out. */
784707d5
JP		 812 if ((arg & 512) && !SvOK(sv)) {
813 arg = fieldsize;
814 while (arg--)
815 *t++ = ' ';
816 break;
817 }
818 gotsome = TRUE;
819 value = SvNV(sv);
a1b95068 820 /* overflow evidence */
bfed75c6 821 if (num_overflow(value, fieldsize, arg)) {
a1b95068
WL		 822 arg = fieldsize;
823 while (arg--)
824 *t++ = '#';
825 break;
826 }
784707d5
JP		 827 /* Formats aren't yet marked for locales, so assume "yes". */
828 {
829 STORE_NUMERIC_STANDARD_SET_LOCAL();
a1b95068 830 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
784707d5
JP		 831 RESTORE_NUMERIC_STANDARD();
832 }
833 t += fieldsize;
834 break;
a1b95068 835
a0d0e21e
LW		 836 case FF_NEWLINE:
837 f++;
838 while (t-- > linemark && *t == ' ') ;
839 t++;
840 *t++ = '\n';
841 break;
842
843 case FF_BLANK:
844 arg = *fpc++;
845 if (gotsome) {
846 if (arg) { /* repeat until fields exhausted? */
847 *t = '\0';
b15aece3 848 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
3280af22 849 lines += FmLINES(PL_formtarget);
a0d0e21e
LW		 850 if (lines == 200) {
851 arg = t - linemark;
852 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 853 DIE(aTHX_ "Runaway format");
a0d0e21e 854 }
1bd51a4c
IH		 855 if (targ_is_utf8)
856 SvUTF8_on(PL_formtarget);
3280af22 857 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW		 858 SP = ORIGMARK;
859 RETURNOP(cLISTOP->op_first);
860 }
861 }
862 else {
863 t = linemark;
864 lines--;
865 }
866 break;
867
868 case FF_MORE:
5a34cab7
NC		 869 {
870 const char *s = chophere;
871 const char *send = item + len;
872 if (chopspace) {
af68e756 873 while (isSPACE(*s) && (s < send))
5a34cab7 874 s++;
a0d0e21e 875 }
5a34cab7
NC		 876 if (s < send) {
877 char *s1;
878 arg = fieldsize - itemsize;
879 if (arg) {
880 fieldsize -= arg;
881 while (arg-- > 0)
882 *t++ = ' ';
883 }
884 s1 = t - 3;
885 if (strnEQ(s1," ",3)) {
886 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
887 s1--;
888 }
889 *s1++ = '.';
890 *s1++ = '.';
891 *s1++ = '.';
a0d0e21e 892 }
5a34cab7 893 break;
a0d0e21e 894 }
a0d0e21e
LW		 895 case FF_END:
896 *t = '\0';
b15aece3 897 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1bd51a4c
IH		 898 if (targ_is_utf8)
899 SvUTF8_on(PL_formtarget);
3280af22 900 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW		 901 SP = ORIGMARK;
902 RETPUSHYES;
903 }
904 }
905}
906
907PP(pp_grepstart)
908{
27da23d5 909 dVAR; dSP;
a0d0e21e
LW		 910 SV *src;
911
3280af22 912 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 913 (void)POPMARK;
54310121 914 if (GIMME_V == G_SCALAR)
0b024f31 915 XPUSHs(sv_2mortal(newSViv(0)));
533c011a 916 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 917 }
3280af22 918 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS		 919 pp_pushmark(); /* push dst */
920 pp_pushmark(); /* push src */
a0d0e21e
LW		 921 ENTER; /* enter outer scope */
922
923 SAVETMPS;
59f00321
RGS		 924 if (PL_op->op_private & OPpGREP_LEX)
925 SAVESPTR(PAD_SVl(PL_op->op_targ));
926 else
927 SAVE_DEFSV;
a0d0e21e 928 ENTER; /* enter inner scope */
7766f137 929 SAVEVPTR(PL_curpm);
a0d0e21e 930
3280af22 931 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 932 SvTEMP_off(src);
59f00321
RGS		 933 if (PL_op->op_private & OPpGREP_LEX)
934 PAD_SVl(PL_op->op_targ) = src;
935 else
936 DEFSV = src;
a0d0e21e
LW		 937
938 PUTBACK;
533c011a 939 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 940 pp_pushmark(); /* push top */
533c011a 941 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 942}
943
a0d0e21e
LW		 944PP(pp_mapwhile)
945{
27da23d5 946 dVAR; dSP;
f54cb97a 947 const I32 gimme = GIMME_V;
544f3153 948 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW		 949 I32 count;
950 I32 shift;
951 SV** src;
ac27b0f5 952 SV** dst;
a0d0e21e 953
544f3153 954 /* first, move source pointer to the next item in the source list */
3280af22 955 ++PL_markstack_ptr[-1];
544f3153
GS		 956
957 /* if there are new items, push them into the destination list */
4c90a460 958 if (items && gimme != G_VOID) {
544f3153
GS		 959 /* might need to make room back there first */
960 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
961 /* XXX this implementation is very pessimal because the stack
962 * is repeatedly extended for every set of items. Is possible
963 * to do this without any stack extension or copying at all
964 * by maintaining a separate list over which the map iterates
18ef8bea 965 * (like foreach does). --gsar */
544f3153
GS		 966
967 /* everything in the stack after the destination list moves
968 * towards the end the stack by the amount of room needed */
969 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
970
971 /* items to shift up (accounting for the moved source pointer) */
972 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT		 973
974 /* This optimization is by Ben Tilly and it does
975 * things differently from what Sarathy (gsar)
976 * is describing. The downside of this optimization is
977 * that leaves "holes" (uninitialized and hopefully unused areas)
978 * to the Perl stack, but on the other hand this
979 * shouldn't be a problem. If Sarathy's idea gets
980 * implemented, this optimization should become
981 * irrelevant. --jhi */
982 if (shift < count)
983 shift = count; /* Avoid shifting too often --Ben Tilly */
bfed75c6 984
924508f0
GS		 985 EXTEND(SP,shift);
986 src = SP;
987 dst = (SP += shift);
3280af22
NIS		 988 PL_markstack_ptr[-1] += shift;
989 *PL_markstack_ptr += shift;
544f3153 990 while (count--)
a0d0e21e
LW		 991 *dst-- = *src--;
992 }
544f3153 993 /* copy the new items down to the destination list */
ac27b0f5 994 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26
TP		 995 if (gimme == G_ARRAY) {
996 while (items-- > 0)
997 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
998 }
bfed75c6 999 else {
22023b26
TP		 1000 /* scalar context: we don't care about which values map returns
1001 * (we use undef here). And so we certainly don't want to do mortal
1002 * copies of meaningless values. */
1003 while (items-- > 0) {
b988aa42 1004 (void)POPs;
22023b26
TP		 1005 *dst-- = &PL_sv_undef;
1006 }
1007 }
a0d0e21e
LW		 1008 }
1009 LEAVE; /* exit inner scope */
1010
1011 /* All done yet? */
3280af22 1012 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW		 1013
1014 (void)POPMARK; /* pop top */
1015 LEAVE; /* exit outer scope */
1016 (void)POPMARK; /* pop src */
3280af22 1017 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1018 (void)POPMARK; /* pop dst */
3280af22 1019 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1020 if (gimme == G_SCALAR) {
7cc47870
RGS		 1021 if (PL_op->op_private & OPpGREP_LEX) {
1022 SV* sv = sv_newmortal();
1023 sv_setiv(sv, items);
1024 PUSHs(sv);
1025 }
1026 else {
1027 dTARGET;
1028 XPUSHi(items);
1029 }
a0d0e21e 1030 }
54310121 1031 else if (gimme == G_ARRAY)
1032 SP += items;
a0d0e21e
LW		 1033 RETURN;
1034 }
1035 else {
1036 SV *src;
1037
1038 ENTER; /* enter inner scope */
7766f137 1039 SAVEVPTR(PL_curpm);
a0d0e21e 1040
544f3153 1041 /* set $_ to the new source item */
3280af22 1042 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1043 SvTEMP_off(src);
59f00321
RGS		 1044 if (PL_op->op_private & OPpGREP_LEX)
1045 PAD_SVl(PL_op->op_targ) = src;
1046 else
1047 DEFSV = src;
a0d0e21e
LW		 1048
1049 RETURNOP(cLOGOP->op_other);
1050 }
1051}
1052
a0d0e21e
LW		 1053/* Range stuff. */
1054
1055PP(pp_range)
1056{
97aff369 1057 dVAR;
a0d0e21e 1058 if (GIMME == G_ARRAY)
1a67a97c 1059 return NORMAL;
538573f7 1060 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1061 return cLOGOP->op_other;
538573f7 1062 else
1a67a97c 1063 return NORMAL;
a0d0e21e
LW		 1064}
1065
1066PP(pp_flip)
1067{
97aff369 1068 dVAR;
39644a26 1069 dSP;
a0d0e21e
LW		 1070
1071 if (GIMME == G_ARRAY) {
1a67a97c 1072 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1073 }
1074 else {
1075 dTOPss;
44f8325f 1076 SV * const targ = PAD_SV(PL_op->op_targ);
bfed75c6 1077 int flip = 0;
790090df 1078
bfed75c6 1079 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST		 1080 if (GvIO(PL_last_in_gv)) {
1081 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1082 }
1083 else {
fafc274c 1084 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
44f8325f
AL		 1085 if (gv && GvSV(gv))
1086 flip = SvIV(sv) == SvIV(GvSV(gv));
4e3399f9 1087 }
bfed75c6
AL		 1088 } else {
1089 flip = SvTRUE(sv);
1090 }
1091 if (flip) {
a0d0e21e 1092 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1093 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1094 sv_setiv(targ, 1);
3e3baf6d 1095 SETs(targ);
a0d0e21e
LW		 1096 RETURN;
1097 }
1098 else {
1099 sv_setiv(targ, 0);
924508f0 1100 SP--;
1a67a97c 1101 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1102 }
1103 }
c69006e4 1104 sv_setpvn(TARG, "", 0);
a0d0e21e
LW		 1105 SETs(targ);
1106 RETURN;
1107 }
1108}
1109
8e9bbdb9
RGS		 1110/* This code tries to decide if "$left .. $right" should use the
1111 magical string increment, or if the range is numeric (we make
1112 an exception for .."0" [#18165]). AMS 20021031. */
1113
1114#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS		 1115 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1116 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e 1117 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
b15aece3 1118 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
e0ab1c0e 1119 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1120
a0d0e21e
LW		 1121PP(pp_flop)
1122{
97aff369 1123 dVAR; dSP;
a0d0e21e
LW		 1124
1125 if (GIMME == G_ARRAY) {
1126 dPOPPOPssrl;
86cb7173 1127
5b295bef
RD		 1128 SvGETMAGIC(left);
1129 SvGETMAGIC(right);
a0d0e21e 1130
8e9bbdb9 1131 if (RANGE_IS_NUMERIC(left,right)) {
901017d6
AL		 1132 register IV i, j;
1133 IV max;
4fe3f0fa
MHM		 1134 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1135 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1136 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1137 i = SvIV(left);
1138 max = SvIV(right);
bbce6d69 1139 if (max >= i) {
c1ab3db2
AK		 1140 j = max - i + 1;
1141 EXTEND_MORTAL(j);
1142 EXTEND(SP, j);
bbce6d69 1143 }
c1ab3db2
AK		 1144 else
1145 j = 0;
1146 while (j--) {
901017d6 1147 SV * const sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1148 PUSHs(sv);
1149 }
1150 }
1151 else {
44f8325f 1152 SV * const final = sv_mortalcopy(right);
13c5b33c 1153 STRLEN len;
823a54a3 1154 const char * const tmps = SvPV_const(final, len);
a0d0e21e 1155
901017d6 1156 SV *sv = sv_mortalcopy(left);
13c5b33c 1157 SvPV_force_nolen(sv);
89ea2908 1158 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1159 XPUSHs(sv);
b15aece3 1160 if (strEQ(SvPVX_const(sv),tmps))
89ea2908 1161 break;
a0d0e21e
LW		 1162 sv = sv_2mortal(newSVsv(sv));
1163 sv_inc(sv);
1164 }
a0d0e21e
LW		 1165 }
1166 }
1167 else {
1168 dTOPss;
901017d6 1169 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1170 int flop = 0;
a0d0e21e 1171 sv_inc(targ);
4e3399f9
YST		 1172
1173 if (PL_op->op_private & OPpFLIP_LINENUM) {
1174 if (GvIO(PL_last_in_gv)) {
1175 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1176 }
1177 else {
fafc274c 1178 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
4e3399f9
YST		 1179 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1180 }
1181 }
1182 else {
1183 flop = SvTRUE(sv);
1184 }
1185
1186 if (flop) {
a0d0e21e 1187 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
396482e1 1188 sv_catpvs(targ, "E0");
a0d0e21e
LW		 1189 }
1190 SETs(targ);
1191 }
1192
1193 RETURN;
1194}
1195
1196/* Control. */
1197
27da23d5 1198static const char * const context_name[] = {
515afda2
NC		 1199 "pseudo-block",
1200 "subroutine",
1201 "eval",
1202 "loop",
1203 "substitution",
1204 "block",
0d863452
RH		 1205 "format",
1206 "given",
1207 "when"
515afda2
NC		 1208};
1209
76e3520e 1210STATIC I32
06b5626a 1211S_dopoptolabel(pTHX_ const char *label)
a0d0e21e 1212{
97aff369 1213 dVAR;
a0d0e21e 1214 register I32 i;
a0d0e21e
LW		 1215
1216 for (i = cxstack_ix; i >= 0; i--) {
901017d6 1217 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1218 switch (CxTYPE(cx)) {
a0d0e21e 1219 case CXt_SUBST:
a0d0e21e 1220 case CXt_SUB:
7766f137 1221 case CXt_FORMAT:
a0d0e21e 1222 case CXt_EVAL:
0a753a76 1223 case CXt_NULL:
0d863452
RH		 1224 case CXt_GIVEN:
1225 case CXt_WHEN:
e476b1b5 1226 if (ckWARN(WARN_EXITING))
515afda2
NC		 1227 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1228 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1229 if (CxTYPE(cx) == CXt_NULL)
1230 return -1;
1231 break;
a0d0e21e 1232 case CXt_LOOP:
901017d6 1233 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1234 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1235 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1236 continue;
1237 }
cea2e8a9 1238 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1239 return i;
1240 }
1241 }
1242 return i;
1243}
1244
0d863452
RH		 1245
1246
e50aee73 1247I32
864dbfa3 1248Perl_dowantarray(pTHX)
e50aee73 1249{
97aff369 1250 dVAR;
f54cb97a 1251 const I32 gimme = block_gimme();
54310121 1252 return (gimme == G_VOID) ? G_SCALAR : gimme;
1253}
1254
1255I32
864dbfa3 1256Perl_block_gimme(pTHX)
54310121 1257{
97aff369 1258 dVAR;
06b5626a 1259 const I32 cxix = dopoptosub(cxstack_ix);
e50aee73 1260 if (cxix < 0)
46fc3d4c 1261 return G_VOID;
e50aee73 1262
54310121 1263 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1264 case G_VOID:
1265 return G_VOID;
54310121 1266 case G_SCALAR:
e50aee73 1267 return G_SCALAR;
54310121 1268 case G_ARRAY:
1269 return G_ARRAY;
1270 default:
cea2e8a9 1271 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1272 /* NOTREACHED */
1273 return 0;
54310121 1274 }
e50aee73
AD		 1275}
1276
78f9721b
SM		 1277I32
1278Perl_is_lvalue_sub(pTHX)
1279{
97aff369 1280 dVAR;
06b5626a 1281 const I32 cxix = dopoptosub(cxstack_ix);
78f9721b
SM		 1282 assert(cxix >= 0); /* We should only be called from inside subs */
1283
1284 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1285 return cxstack[cxix].blk_sub.lval;
1286 else
1287 return 0;
1288}
1289
76e3520e 1290STATIC I32
cea2e8a9 1291S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1292{
97aff369 1293 dVAR;
2c375eb9
GS		 1294 return dopoptosub_at(cxstack, startingblock);
1295}
1296
1297STATIC I32
901017d6 1298S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1299{
97aff369 1300 dVAR;
a0d0e21e 1301 I32 i;
a0d0e21e 1302 for (i = startingblock; i >= 0; i--) {
901017d6 1303 register const PERL_CONTEXT * const cx = &cxstk[i];
6b35e009 1304 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1305 default:
1306 continue;
1307 case CXt_EVAL:
1308 case CXt_SUB:
7766f137 1309 case CXt_FORMAT:
cea2e8a9 1310 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1311 return i;
1312 }
1313 }
1314 return i;
1315}
1316
76e3520e 1317STATIC I32
cea2e8a9 1318S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1319{
97aff369 1320 dVAR;
a0d0e21e 1321 I32 i;
a0d0e21e 1322 for (i = startingblock; i >= 0; i--) {
06b5626a 1323 register const PERL_CONTEXT *cx = &cxstack[i];
6b35e009 1324 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1325 default:
1326 continue;
1327 case CXt_EVAL:
cea2e8a9 1328 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1329 return i;
1330 }
1331 }
1332 return i;
1333}
1334
76e3520e 1335STATIC I32
cea2e8a9 1336S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1337{
97aff369 1338 dVAR;
a0d0e21e 1339 I32 i;
a0d0e21e 1340 for (i = startingblock; i >= 0; i--) {
901017d6 1341 register const PERL_CONTEXT * const cx = &cxstack[i];
6b35e009 1342 switch (CxTYPE(cx)) {
a0d0e21e 1343 case CXt_SUBST:
a0d0e21e 1344 case CXt_SUB:
7766f137 1345 case CXt_FORMAT:
a0d0e21e 1346 case CXt_EVAL:
0a753a76 1347 case CXt_NULL:
e476b1b5 1348 if (ckWARN(WARN_EXITING))
515afda2
NC		 1349 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1350 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1351 if ((CxTYPE(cx)) == CXt_NULL)
1352 return -1;
1353 break;
a0d0e21e 1354 case CXt_LOOP:
cea2e8a9 1355 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1356 return i;
1357 }
1358 }
1359 return i;
1360}
1361
0d863452
RH		 1362STATIC I32
1363S_dopoptogiven(pTHX_ I32 startingblock)
1364{
97aff369 1365 dVAR;
0d863452
RH		 1366 I32 i;
1367 for (i = startingblock; i >= 0; i--) {
1368 register const PERL_CONTEXT *cx = &cxstack[i];
1369 switch (CxTYPE(cx)) {
1370 default:
1371 continue;
1372 case CXt_GIVEN:
1373 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1374 return i;
1375 case CXt_LOOP:
1376 if (CxFOREACHDEF(cx)) {
1377 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1378 return i;
1379 }
1380 }
1381 }
1382 return i;
1383}
1384
1385STATIC I32
1386S_dopoptowhen(pTHX_ I32 startingblock)
1387{
97aff369 1388 dVAR;
0d863452
RH		 1389 I32 i;
1390 for (i = startingblock; i >= 0; i--) {
1391 register const PERL_CONTEXT *cx = &cxstack[i];
1392 switch (CxTYPE(cx)) {
1393 default:
1394 continue;
1395 case CXt_WHEN:
1396 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1397 return i;
1398 }
1399 }
1400 return i;
1401}
1402
a0d0e21e 1403void
864dbfa3 1404Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1405{
97aff369 1406 dVAR;
a0d0e21e
LW		 1407 I32 optype;
1408
1409 while (cxstack_ix > cxix) {
b0d9ce38 1410 SV *sv;
06b5626a 1411 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c90c0ff4 1412 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1413 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1414 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1415 switch (CxTYPE(cx)) {
c90c0ff4 1416 case CXt_SUBST:
1417 POPSUBST(cx);
1418 continue; /* not break */
a0d0e21e 1419 case CXt_SUB:
b0d9ce38
GS		 1420 POPSUB(cx,sv);
1421 LEAVESUB(sv);
a0d0e21e
LW		 1422 break;
1423 case CXt_EVAL:
1424 POPEVAL(cx);
1425 break;
1426 case CXt_LOOP:
1427 POPLOOP(cx);
1428 break;
0a753a76 1429 case CXt_NULL:
a0d0e21e 1430 break;
7766f137
GS		 1431 case CXt_FORMAT:
1432 POPFORMAT(cx);
1433 break;
a0d0e21e 1434 }
c90c0ff4 1435 cxstack_ix--;
a0d0e21e 1436 }
1b6737cc 1437 PERL_UNUSED_VAR(optype);
a0d0e21e
LW		 1438}
1439
5a844595
GS		 1440void
1441Perl_qerror(pTHX_ SV *err)
1442{
97aff369 1443 dVAR;
5a844595
GS		 1444 if (PL_in_eval)
1445 sv_catsv(ERRSV, err);
1446 else if (PL_errors)
1447 sv_catsv(PL_errors, err);
1448 else
894356b3 1449 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS		 1450 ++PL_error_count;
1451}
1452
a0d0e21e 1453OP *
35a4481c 1454Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1455{
27da23d5 1456 dVAR;
87582a92 1457
3280af22 1458 if (PL_in_eval) {
a0d0e21e 1459 I32 cxix;
a0d0e21e 1460 I32 gimme;
a0d0e21e 1461
4e6ea2c3 1462 if (message) {
faef0170 1463 if (PL_in_eval & EVAL_KEEPERR) {
bfed75c6 1464 static const char prefix[] = "\t(in cleanup) ";
2d03de9c 1465 SV * const err = ERRSV;
c445ea15 1466 const char *e = NULL;
98eae8f5 1467 if (!SvPOK(err))
c69006e4 1468 sv_setpvn(err,"",0);
98eae8f5 1469 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
0510663f 1470 STRLEN len;
349d4f2f 1471 e = SvPV_const(err, len);
0510663f 1472 e += len - msglen;
98eae8f5 1473 if (*e != *message || strNE(e,message))
c445ea15 1474 e = NULL;
98eae8f5
GS		 1475 }
1476 if (!e) {
1477 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1478 sv_catpvn(err, prefix, sizeof(prefix)-1);
1479 sv_catpvn(err, message, msglen);
e476b1b5 1480 if (ckWARN(WARN_MISC)) {
504618e9 1481 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
b15aece3 1482 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
4e6ea2c3 1483 }
4633a7c4 1484 }
4633a7c4 1485 }
1aa99e6b 1486 else {
06bf62c7 1487 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1488 }
4633a7c4 1489 }
4e6ea2c3 1490
5a844595
GS		 1491 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1492 && PL_curstackinfo->si_prev)
1493 {
bac4b2ad 1494 dounwind(-1);
d3acc0f7 1495 POPSTACK;
bac4b2ad 1496 }
e336de0d 1497
a0d0e21e
LW		 1498 if (cxix >= 0) {
1499 I32 optype;
35a4481c 1500 register PERL_CONTEXT *cx;
901017d6 1501 SV **newsp;
a0d0e21e
LW		 1502
1503 if (cxix < cxstack_ix)
1504 dounwind(cxix);
1505
3280af22 1506 POPBLOCK(cx,PL_curpm);
6b35e009 1507 if (CxTYPE(cx) != CXt_EVAL) {
16869676 1508 if (!message)
349d4f2f 1509 message = SvPVx_const(ERRSV, msglen);
bf49b057
GS		 1510 PerlIO_write(Perl_error_log, "panic: die ", 11);
1511 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1512 my_exit(1);
1513 }
1514 POPEVAL(cx);
1515
1516 if (gimme == G_SCALAR)
3280af22
NIS		 1517 *++newsp = &PL_sv_undef;
1518 PL_stack_sp = newsp;
a0d0e21e
LW		 1519
1520 LEAVE;
748a9306 1521
7fb6a879
GS		 1522 /* LEAVE could clobber PL_curcop (see save_re_context())
1523 * XXX it might be better to find a way to avoid messing with
1524 * PL_curcop in save_re_context() instead, but this is a more
1525 * minimal fix --GSAR */
1526 PL_curcop = cx->blk_oldcop;
1527
7a2e2cd6 1528 if (optype == OP_REQUIRE) {
44f8325f 1529 const char* const msg = SvPVx_nolen_const(ERRSV);
901017d6 1530 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 1531 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 1532 &PL_sv_undef, 0);
5a844595
GS		 1533 DIE(aTHX_ "%sCompilation failed in require",
1534 *msg ? msg : "Unknown error\n");
7a2e2cd6 1535 }
f39bc417
DM		 1536 assert(CxTYPE(cx) == CXt_EVAL);
1537 return cx->blk_eval.retop;
a0d0e21e
LW		 1538 }
1539 }
9cc2fdd3 1540 if (!message)
349d4f2f 1541 message = SvPVx_const(ERRSV, msglen);
87582a92 1542
7ff03255 1543 write_to_stderr(message, msglen);
f86702cc 1544 my_failure_exit();
1545 /* NOTREACHED */
a0d0e21e
LW		 1546 return 0;
1547}
1548
1549PP(pp_xor)
1550{
97aff369 1551 dVAR; dSP; dPOPTOPssrl;
a0d0e21e
LW		 1552 if (SvTRUE(left) != SvTRUE(right))
1553 RETSETYES;
1554 else
1555 RETSETNO;
1556}
1557
a0d0e21e
LW		 1558PP(pp_caller)
1559{
97aff369 1560 dVAR;
39644a26 1561 dSP;
a0d0e21e 1562 register I32 cxix = dopoptosub(cxstack_ix);
901017d6
AL		 1563 register const PERL_CONTEXT *cx;
1564 register const PERL_CONTEXT *ccstack = cxstack;
1565 const PERL_SI *top_si = PL_curstackinfo;
54310121 1566 I32 gimme;
06b5626a 1567 const char *stashname;
a0d0e21e
LW		 1568 I32 count = 0;
1569
1570 if (MAXARG)
1571 count = POPi;
27d41816 1572
a0d0e21e 1573 for (;;) {
2c375eb9
GS		 1574 /* we may be in a higher stacklevel, so dig down deeper */
1575 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1576 top_si = top_si->si_prev;
1577 ccstack = top_si->si_cxstack;
1578 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1579 }
a0d0e21e 1580 if (cxix < 0) {
27d41816
DM		 1581 if (GIMME != G_ARRAY) {
1582 EXTEND(SP, 1);
a0d0e21e 1583 RETPUSHUNDEF;
27d41816 1584 }
a0d0e21e
LW		 1585 RETURN;
1586 }
f2a7f298
DG		 1587 /* caller() should not report the automatic calls to &DB::sub */
1588 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3280af22 1589 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1590 count++;
1591 if (!count--)
1592 break;
2c375eb9 1593 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1594 }
2c375eb9
GS		 1595
1596 cx = &ccstack[cxix];
7766f137 1597 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
f54cb97a 1598 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2c375eb9 1599 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1600 field below is defined for any cx. */
f2a7f298
DG		 1601 /* caller() should not report the automatic calls to &DB::sub */
1602 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1603 cx = &ccstack[dbcxix];
06a5b730 1604 }
1605
ed094faf 1606 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1607 if (GIMME != G_ARRAY) {
27d41816 1608 EXTEND(SP, 1);
ed094faf 1609 if (!stashname)
3280af22 1610 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1611 else {
1612 dTARGET;
ed094faf 1613 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1614 PUSHs(TARG);
1615 }
a0d0e21e
LW		 1616 RETURN;
1617 }
a0d0e21e 1618
27d41816
DM		 1619 EXTEND(SP, 10);
1620
ed094faf 1621 if (!stashname)
3280af22 1622 PUSHs(&PL_sv_undef);
49d8d3a1 1623 else
ed094faf 1624 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1625 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1626 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1627 if (!MAXARG)
1628 RETURN;
7766f137 1629 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
0bd48802 1630 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1631 /* So is ccstack[dbcxix]. */
07b8c804 1632 if (isGV(cvgv)) {
561b68a9 1633 SV * const sv = newSV(0);
c445ea15 1634 gv_efullname3(sv, cvgv, NULL);
07b8c804
RGS		 1635 PUSHs(sv_2mortal(sv));
1636 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1637 }
1638 else {
396482e1 1639 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
72699b0f 1640 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1641 }
a0d0e21e
LW		 1642 }
1643 else {
396482e1 1644 PUSHs(sv_2mortal(newSVpvs("(eval)")));
a0d0e21e
LW		 1645 PUSHs(sv_2mortal(newSViv(0)));
1646 }
54310121 1647 gimme = (I32)cx->blk_gimme;
1648 if (gimme == G_VOID)
3280af22 1649 PUSHs(&PL_sv_undef);
54310121 1650 else
1651 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1652 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1653 /* eval STRING */
06a5b730 1654 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1655 PUSHs(cx->blk_eval.cur_text);
3280af22 1656 PUSHs(&PL_sv_no);
0f79a09d 1657 }
811a4de9 1658 /* require */
0f79a09d
GS		 1659 else if (cx->blk_eval.old_namesv) {
1660 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1661 PUSHs(&PL_sv_yes);
06a5b730 1662 }
811a4de9
GS		 1663 /* eval BLOCK (try blocks have old_namesv == 0) */
1664 else {
1665 PUSHs(&PL_sv_undef);
1666 PUSHs(&PL_sv_undef);
1667 }
4633a7c4 1668 }
a682de96
GS		 1669 else {
1670 PUSHs(&PL_sv_undef);
1671 PUSHs(&PL_sv_undef);
1672 }
1673 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1674 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1675 {
66a1b24b
AL		 1676 AV * const ary = cx->blk_sub.argarray;
1677 const int off = AvARRAY(ary) - AvALLOC(ary);
a0d0e21e 1678
3280af22 1679 if (!PL_dbargs) {
71315bf2 1680 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
0bd48802 1681 PL_dbargs = GvAV(gv_AVadd(tmpgv));
a5f75d66 1682 GvMULTI_on(tmpgv);
3ddcf04c 1683 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW		 1684 }
1685
3280af22
NIS		 1686 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1687 av_extend(PL_dbargs, AvFILLp(ary) + off);
1688 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1689 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1690 }
f3aa04c2
GS		 1691 /* XXX only hints propagated via op_private are currently
1692 * visible (others are not easily accessible, since they
1693 * use the global PL_hints) */
1694 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1695 HINT_PRIVATE_MASK)));
e476b1b5
GS		 1696 {
1697 SV * mask ;
0bd48802 1698 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1699
ac27b0f5 1700 if (old_warnings == pWARN_NONE ||
114bafba 1701 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1702 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1703 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1704 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1705 /* Get the bit mask for $warnings::Bits{all}, because
1706 * it could have been extended by warnings::register */
1707 SV **bits_all;
0bd48802 1708 HV * const bits = get_hv("warnings::Bits", FALSE);
017a3ce5 1709 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
75b6c4ca
RGS		 1710 mask = newSVsv(*bits_all);
1711 }
1712 else {
1713 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1714 }
1715 }
e476b1b5
GS		 1716 else
1717 mask = newSVsv(old_warnings);
1718 PUSHs(sv_2mortal(mask));
1719 }
a0d0e21e
LW		 1720 RETURN;
1721}
1722
a0d0e21e
LW		 1723PP(pp_reset)
1724{
97aff369 1725 dVAR;
39644a26 1726 dSP;
0bd48802 1727 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
11faa288 1728 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1729 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1730 RETURN;
1731}
1732
dd2155a4
DM		 1733/* like pp_nextstate, but used instead when the debugger is active */
1734
a0d0e21e
LW		 1735PP(pp_dbstate)
1736{
27da23d5 1737 dVAR;
533c011a 1738 PL_curcop = (COP*)PL_op;
a0d0e21e 1739 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1740 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1741 FREETMPS;
1742
5df8de69
DM		 1743 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1744 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1745 {
39644a26 1746 dSP;
c09156bb 1747 register PERL_CONTEXT *cx;
f54cb97a 1748 const I32 gimme = G_ARRAY;
eb160463 1749 U8 hasargs;
0bd48802
AL		 1750 GV * const gv = PL_DBgv;
1751 register CV * const cv = GvCV(gv);
a0d0e21e 1752
a0d0e21e 1753 if (!cv)
cea2e8a9 1754 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1755
aea4f609
DM		 1756 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1757 /* don't do recursive DB::DB call */
a0d0e21e 1758 return NORMAL;
748a9306 1759
4633a7c4
LW		 1760 ENTER;
1761 SAVETMPS;
1762
3280af22 1763 SAVEI32(PL_debug);
55497cff 1764 SAVESTACK_POS();
3280af22 1765 PL_debug = 0;
748a9306 1766 hasargs = 0;
924508f0 1767 SPAGAIN;
748a9306 1768
aed2304a 1769 if (CvISXSUB(cv)) {
c127bd3a
SF		 1770 CvDEPTH(cv)++;
1771 PUSHMARK(SP);
1772 (void)(*CvXSUB(cv))(aTHX_ cv);
1773 CvDEPTH(cv)--;
1774 FREETMPS;
1775 LEAVE;
1776 return NORMAL;
1777 }
1778 else {
1779 PUSHBLOCK(cx, CXt_SUB, SP);
1780 PUSHSUB_DB(cx);
1781 cx->blk_sub.retop = PL_op->op_next;
1782 CvDEPTH(cv)++;
1783 SAVECOMPPAD();
1784 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1785 RETURNOP(CvSTART(cv));
1786 }
a0d0e21e
LW		 1787 }
1788 else
1789 return NORMAL;
1790}
1791
a0d0e21e
LW		 1792PP(pp_enteriter)
1793{
27da23d5 1794 dVAR; dSP; dMARK;
c09156bb 1795 register PERL_CONTEXT *cx;
f54cb97a 1796 const I32 gimme = GIMME_V;
a0d0e21e 1797 SV **svp;
0d863452 1798 U32 cxtype = CXt_LOOP | CXp_FOREACH;
7766f137
GS		 1799#ifdef USE_ITHREADS
1800 void *iterdata;
1801#endif
a0d0e21e 1802
4633a7c4
LW		 1803 ENTER;
1804 SAVETMPS;
1805
533c011a 1806 if (PL_op->op_targ) {
14f338dc
DM		 1807 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1808 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1809 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1810 SVs_PADSTALE, SVs_PADSTALE);
1811 }
c3564e5c 1812#ifndef USE_ITHREADS
dd2155a4 1813 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1814 SAVESPTR(*svp);
c3564e5c
GS		 1815#else
1816 SAVEPADSV(PL_op->op_targ);
cbfa9890 1817 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1818 cxtype |= CXp_PADVAR;
1819#endif
54b9620d
MB		 1820 }
1821 else {
0bd48802 1822 GV * const gv = (GV*)POPs;
7766f137 1823 svp = &GvSV(gv); /* symbol table variable */
0214ae40 1824 SAVEGENERICSV(*svp);
561b68a9 1825 *svp = newSV(0);
7766f137
GS		 1826#ifdef USE_ITHREADS
1827 iterdata = (void*)gv;
1828#endif
54b9620d 1829 }
4633a7c4 1830
0d863452
RH		 1831 if (PL_op->op_private & OPpITER_DEF)
1832 cxtype |= CXp_FOR_DEF;
1833
a0d0e21e
LW		 1834 ENTER;
1835
7766f137
GS		 1836 PUSHBLOCK(cx, cxtype, SP);
1837#ifdef USE_ITHREADS
1838 PUSHLOOP(cx, iterdata, MARK);
1839#else
a0d0e21e 1840 PUSHLOOP(cx, svp, MARK);
7766f137 1841#endif
533c011a 1842 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1843 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1844 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1845 dPOPss;
0bd48802 1846 SV * const right = (SV*)cx->blk_loop.iterary;
984a4bea
RD		 1847 SvGETMAGIC(sv);
1848 SvGETMAGIC(right);
4fe3f0fa
MHM		 1849 if (RANGE_IS_NUMERIC(sv,right)) {
1850 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1851 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1852 DIE(aTHX_ "Range iterator outside integer range");
1853 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1854 cx->blk_loop.itermax = SvIV(right);
d4665a05
DM		 1855#ifdef DEBUGGING
1856 /* for correct -Dstv display */
1857 cx->blk_oldsp = sp - PL_stack_base;
1858#endif
89ea2908 1859 }
3f63a782 1860 else {
89ea2908 1861 cx->blk_loop.iterlval = newSVsv(sv);
13c5b33c 1862 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
10516c54 1863 (void) SvPV_nolen_const(right);
3f63a782 1864 }
89ea2908 1865 }
ef3e5ea9 1866 else if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1867 cx->blk_loop.itermax = 0;
1868 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
ef3e5ea9
NC		 1869
1870 }
89ea2908 1871 }
4633a7c4 1872 else {
3280af22
NIS		 1873 cx->blk_loop.iterary = PL_curstack;
1874 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9 1875 if (PL_op->op_private & OPpITER_REVERSED) {
6e585ca0
DM		 1876 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1877 cx->blk_loop.iterix = cx->blk_oldsp + 1;
ef3e5ea9
NC		 1878 }
1879 else {
1880 cx->blk_loop.iterix = MARK - PL_stack_base;
1881 }
4633a7c4 1882 }
a0d0e21e
LW		 1883
1884 RETURN;
1885}
1886
1887PP(pp_enterloop)
1888{
27da23d5 1889 dVAR; dSP;
c09156bb 1890 register PERL_CONTEXT *cx;
f54cb97a 1891 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1892
1893 ENTER;
1894 SAVETMPS;
1895 ENTER;
1896
1897 PUSHBLOCK(cx, CXt_LOOP, SP);
1898 PUSHLOOP(cx, 0, SP);
1899
1900 RETURN;
1901}
1902
1903PP(pp_leaveloop)
1904{
27da23d5 1905 dVAR; dSP;
c09156bb 1906 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1907 I32 gimme;
1908 SV **newsp;
1909 PMOP *newpm;
1910 SV **mark;
1911
1912 POPBLOCK(cx,newpm);
3a1b2b9e 1913 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1914 mark = newsp;
a8bba7fa 1915 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1916
a1f49e72 1917 TAINT_NOT;
54310121 1918 if (gimme == G_VOID)
bb263b4e 1919 /*EMPTY*/; /* do nothing */
54310121 1920 else if (gimme == G_SCALAR) {
1921 if (mark < SP)
1922 *++newsp = sv_mortalcopy(*SP);
1923 else
3280af22 1924 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1925 }
1926 else {
a1f49e72 1927 while (mark < SP) {
a0d0e21e 1928 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1929 TAINT_NOT; /* Each item is independent */
1930 }
a0d0e21e 1931 }
f86702cc 1932 SP = newsp;
1933 PUTBACK;
1934
a8bba7fa 1935 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1936 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1937
a0d0e21e
LW		 1938 LEAVE;
1939 LEAVE;
1940
f86702cc 1941 return NORMAL;
a0d0e21e
LW		 1942}
1943
1944PP(pp_return)
1945{
27da23d5 1946 dVAR; dSP; dMARK;
c09156bb 1947 register PERL_CONTEXT *cx;
f86702cc 1948 bool popsub2 = FALSE;
b45de488 1949 bool clear_errsv = FALSE;
a0d0e21e
LW		 1950 I32 gimme;
1951 SV **newsp;
1952 PMOP *newpm;
1953 I32 optype = 0;
b0d9ce38 1954 SV *sv;
f39bc417 1955 OP *retop;
a0d0e21e 1956
0bd48802
AL		 1957 const I32 cxix = dopoptosub(cxstack_ix);
1958
9850bf21
RH		 1959 if (cxix < 0) {
1960 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1961 * sort block, which is a CXt_NULL
1962 * not a CXt_SUB */
1963 dounwind(0);
d7507f74
RH		 1964 PL_stack_base[1] = *PL_stack_sp;
1965 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1966 return 0;
1967 }
9850bf21
RH		 1968 else
1969 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e 1970 }
a0d0e21e
LW		 1971 if (cxix < cxstack_ix)
1972 dounwind(cxix);
1973
d7507f74
RH		 1974 if (CxMULTICALL(&cxstack[cxix])) {
1975 gimme = cxstack[cxix].blk_gimme;
1976 if (gimme == G_VOID)
1977 PL_stack_sp = PL_stack_base;
1978 else if (gimme == G_SCALAR) {
1979 PL_stack_base[1] = *PL_stack_sp;
1980 PL_stack_sp = PL_stack_base + 1;
1981 }
9850bf21 1982 return 0;
d7507f74 1983 }
9850bf21 1984
a0d0e21e 1985 POPBLOCK(cx,newpm);
6b35e009 1986 switch (CxTYPE(cx)) {
a0d0e21e 1987 case CXt_SUB:
f86702cc 1988 popsub2 = TRUE;
f39bc417 1989 retop = cx->blk_sub.retop;
5dd42e15 1990 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 1991 break;
1992 case CXt_EVAL:
b45de488
GS		 1993 if (!(PL_in_eval & EVAL_KEEPERR))
1994 clear_errsv = TRUE;
a0d0e21e 1995 POPEVAL(cx);
f39bc417 1996 retop = cx->blk_eval.retop;
1d76a5c3
GS		 1997 if (CxTRYBLOCK(cx))
1998 break;
067f92a0 1999 lex_end();
748a9306
LW		 2000 if (optype == OP_REQUIRE &&
2001 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2002 {
54310121 2003 /* Unassume the success we assumed earlier. */
901017d6 2004 SV * const nsv = cx->blk_eval.old_namesv;
b15aece3 2005 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 2006 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 2007 }
a0d0e21e 2008 break;
7766f137
GS		 2009 case CXt_FORMAT:
2010 POPFORMAT(cx);
f39bc417 2011 retop = cx->blk_sub.retop;
7766f137 2012 break;
a0d0e21e 2013 default:
cea2e8a9 2014 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 2015 }
2016
a1f49e72 2017 TAINT_NOT;
a0d0e21e 2018 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 2019 if (MARK < SP) {
2020 if (popsub2) {
a8bba7fa 2021 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 2022 if (SvTEMP(TOPs)) {
2023 *++newsp = SvREFCNT_inc(*SP);
2024 FREETMPS;
2025 sv_2mortal(*newsp);
959e3673
GS		 2026 }
2027 else {
2028 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2029 FREETMPS;
959e3673
GS		 2030 *++newsp = sv_mortalcopy(sv);
2031 SvREFCNT_dec(sv);
a29cdaf0 2032 }
959e3673
GS		 2033 }
2034 else
a29cdaf0 2035 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2036 }
2037 else
a29cdaf0 2038 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2039 }
2040 else
3280af22 2041 *++newsp = &PL_sv_undef;
a0d0e21e 2042 }
54310121 2043 else if (gimme == G_ARRAY) {
a1f49e72 2044 while (++MARK <= SP) {
f86702cc 2045 *++newsp = (popsub2 && SvTEMP(*MARK))
2046 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2047 TAINT_NOT; /* Each item is independent */
2048 }
a0d0e21e 2049 }
3280af22 2050 PL_stack_sp = newsp;
a0d0e21e 2051
5dd42e15 2052 LEAVE;
f86702cc 2053 /* Stack values are safe: */
2054 if (popsub2) {
5dd42e15 2055 cxstack_ix--;
b0d9ce38 2056 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2057 }
b0d9ce38 2058 else
c445ea15 2059 sv = NULL;
3280af22 2060 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2061
b0d9ce38 2062 LEAVESUB(sv);
b45de488 2063 if (clear_errsv)
c69006e4 2064 sv_setpvn(ERRSV,"",0);
f39bc417 2065 return retop;
a0d0e21e
LW		 2066}
2067
2068PP(pp_last)
2069{
27da23d5 2070 dVAR; dSP;
a0d0e21e 2071 I32 cxix;
c09156bb 2072 register PERL_CONTEXT *cx;
f86702cc 2073 I32 pop2 = 0;
a0d0e21e 2074 I32 gimme;
8772537c 2075 I32 optype;
a0d0e21e
LW		 2076 OP *nextop;
2077 SV **newsp;
2078 PMOP *newpm;
a8bba7fa 2079 SV **mark;
c445ea15 2080 SV *sv = NULL;
9d4ba2ae 2081
a0d0e21e 2082
533c011a 2083 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2084 cxix = dopoptoloop(cxstack_ix);
2085 if (cxix < 0)
a651a37d 2086 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2087 }
2088 else {
2089 cxix = dopoptolabel(cPVOP->op_pv);
2090 if (cxix < 0)
cea2e8a9 2091 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2092 }
2093 if (cxix < cxstack_ix)
2094 dounwind(cxix);
2095
2096 POPBLOCK(cx,newpm);
5dd42e15 2097 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2098 mark = newsp;
6b35e009 2099 switch (CxTYPE(cx)) {
a0d0e21e 2100 case CXt_LOOP:
f86702cc 2101 pop2 = CXt_LOOP;
a8bba7fa
GS		 2102 newsp = PL_stack_base + cx->blk_loop.resetsp;
2103 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2104 break;
f86702cc 2105 case CXt_SUB:
f86702cc 2106 pop2 = CXt_SUB;
f39bc417 2107 nextop = cx->blk_sub.retop;
a0d0e21e 2108 break;
f86702cc 2109 case CXt_EVAL:
2110 POPEVAL(cx);
f39bc417 2111 nextop = cx->blk_eval.retop;
a0d0e21e 2112 break;
7766f137
GS		 2113 case CXt_FORMAT:
2114 POPFORMAT(cx);
f39bc417 2115 nextop = cx->blk_sub.retop;
7766f137 2116 break;
a0d0e21e 2117 default:
cea2e8a9 2118 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2119 }
2120
a1f49e72 2121 TAINT_NOT;
a0d0e21e 2122 if (gimme == G_SCALAR) {
f86702cc 2123 if (MARK < SP)
2124 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2125 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2126 else
3280af22 2127 *++newsp = &PL_sv_undef;
a0d0e21e 2128 }
54310121 2129 else if (gimme == G_ARRAY) {
a1f49e72 2130 while (++MARK <= SP) {
f86702cc 2131 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2132 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2133 TAINT_NOT; /* Each item is independent */
2134 }
f86702cc 2135 }
2136 SP = newsp;
2137 PUTBACK;
2138
5dd42e15
DM		 2139 LEAVE;
2140 cxstack_ix--;
f86702cc 2141 /* Stack values are safe: */
2142 switch (pop2) {
2143 case CXt_LOOP:
a8bba7fa 2144 POPLOOP(cx); /* release loop vars ... */
4fdae800 2145 LEAVE;
f86702cc 2146 break;
2147 case CXt_SUB:
b0d9ce38 2148 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2149 break;
a0d0e21e 2150 }
3280af22 2151 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2152
b0d9ce38 2153 LEAVESUB(sv);
9d4ba2ae
AL		 2154 PERL_UNUSED_VAR(optype);
2155 PERL_UNUSED_VAR(gimme);
f86702cc 2156 return nextop;
a0d0e21e
LW		 2157}
2158
2159PP(pp_next)
2160{
27da23d5 2161 dVAR;
a0d0e21e 2162 I32 cxix;
c09156bb 2163 register PERL_CONTEXT *cx;
85538317 2164 I32 inner;
a0d0e21e 2165
533c011a 2166 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2167 cxix = dopoptoloop(cxstack_ix);
2168 if (cxix < 0)
a651a37d 2169 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2170 }
2171 else {
2172 cxix = dopoptolabel(cPVOP->op_pv);
2173 if (cxix < 0)
cea2e8a9 2174 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2175 }
2176 if (cxix < cxstack_ix)
2177 dounwind(cxix);
2178
85538317
GS		 2179 /* clear off anything above the scope we're re-entering, but
2180 * save the rest until after a possible continue block */
2181 inner = PL_scopestack_ix;
1ba6ee2b 2182 TOPBLOCK(cx);
85538317
GS		 2183 if (PL_scopestack_ix < inner)
2184 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2185 PL_curcop = cx->blk_oldcop;
1ba6ee2b 2186 return cx->blk_loop.next_op;
a0d0e21e
LW		 2187}
2188
2189PP(pp_redo)
2190{
27da23d5 2191 dVAR;
a0d0e21e 2192 I32 cxix;
c09156bb 2193 register PERL_CONTEXT *cx;
a0d0e21e 2194 I32 oldsave;
a034e688 2195 OP* redo_op;
a0d0e21e 2196
533c011a 2197 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2198 cxix = dopoptoloop(cxstack_ix);
2199 if (cxix < 0)
a651a37d 2200 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2201 }
2202 else {
2203 cxix = dopoptolabel(cPVOP->op_pv);
2204 if (cxix < 0)
cea2e8a9 2205 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2206 }
2207 if (cxix < cxstack_ix)
2208 dounwind(cxix);
2209
a034e688
DM		 2210 redo_op = cxstack[cxix].blk_loop.redo_op;
2211 if (redo_op->op_type == OP_ENTER) {
2212 /* pop one less context to avoid $x being freed in while (my $x..) */
2213 cxstack_ix++;
2214 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2215 redo_op = redo_op->op_next;
2216 }
2217
a0d0e21e 2218 TOPBLOCK(cx);
3280af22 2219 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2220 LEAVE_SCOPE(oldsave);
936c78b5 2221 FREETMPS;
3a1b2b9e 2222 PL_curcop = cx->blk_oldcop;
a034e688 2223 return redo_op;
a0d0e21e
LW		 2224}
2225
0824fdcb 2226STATIC OP *
bfed75c6 2227S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2228{
97aff369 2229 dVAR;
a0d0e21e 2230 OP **ops = opstack;
bfed75c6 2231 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2232
fc36a67e 2233 if (ops >= oplimit)
cea2e8a9 2234 Perl_croak(aTHX_ too_deep);
11343788
MB		 2235 if (o->op_type == OP_LEAVE ||
2236 o->op_type == OP_SCOPE ||
2237 o->op_type == OP_LEAVELOOP ||
33d34e4c 2238 o->op_type == OP_LEAVESUB ||
11343788 2239 o->op_type == OP_LEAVETRY)
fc36a67e 2240 {
5dc0d613 2241 *ops++ = cUNOPo->op_first;
fc36a67e 2242 if (ops >= oplimit)
cea2e8a9 2243 Perl_croak(aTHX_ too_deep);
fc36a67e 2244 }
c4aa4e48 2245 *ops = 0;
11343788 2246 if (o->op_flags & OPf_KIDS) {
aec46f14 2247 OP *kid;
a0d0e21e 2248 /* First try all the kids at this level, since that's likeliest. */
11343788 2249 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2250 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2251 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2252 return kid;
2253 }
11343788 2254 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2255 if (kid == PL_lastgotoprobe)
a0d0e21e 2256 continue;
ed8d0fe2
SM		 2257 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2258 if (ops == opstack)
2259 *ops++ = kid;
2260 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2261 ops[-1]->op_type == OP_DBSTATE)
2262 ops[-1] = kid;
2263 else
2264 *ops++ = kid;
2265 }
155aba94 2266 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2267 return o;
a0d0e21e
LW		 2268 }
2269 }
c4aa4e48 2270 *ops = 0;
a0d0e21e
LW		 2271 return 0;
2272}
2273
a0d0e21e
LW		 2274PP(pp_goto)
2275{
27da23d5 2276 dVAR; dSP;
cbbf8932 2277 OP *retop = NULL;
a0d0e21e 2278 I32 ix;
c09156bb 2279 register PERL_CONTEXT *cx;
fc36a67e 2280#define GOTO_DEPTH 64
2281 OP *enterops[GOTO_DEPTH];
cbbf8932 2282 const char *label = NULL;
bfed75c6
AL		 2283 const bool do_dump = (PL_op->op_type == OP_DUMP);
2284 static const char must_have_label[] = "goto must have label";
a0d0e21e 2285
533c011a 2286 if (PL_op->op_flags & OPf_STACKED) {
9d4ba2ae 2287 SV * const sv = POPs;
a0d0e21e
LW		 2288
2289 /* This egregious kludge implements goto &subroutine */
2290 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2291 I32 cxix;
c09156bb 2292 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2293 CV* cv = (CV*)SvRV(sv);
2294 SV** mark;
2295 I32 items = 0;
2296 I32 oldsave;
b1464ded 2297 bool reified = 0;
a0d0e21e 2298
e8f7dd13 2299 retry:
4aa0a1f7 2300 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2301 const GV * const gv = CvGV(cv);
e8f7dd13 2302 if (gv) {
7fc63493 2303 GV *autogv;
e8f7dd13
GS		 2304 SV *tmpstr;
2305 /* autoloaded stub? */
2306 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2307 goto retry;
2308 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2309 GvNAMELEN(gv), FALSE);
2310 if (autogv && (cv = GvCV(autogv)))
2311 goto retry;
2312 tmpstr = sv_newmortal();
c445ea15 2313 gv_efullname3(tmpstr, gv, NULL);
35c1215d 2314 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2315 }
cea2e8a9 2316 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2317 }
2318
a0d0e21e 2319 /* First do some returnish stuff. */
7fc63493 2320 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2321 FREETMPS;
a0d0e21e
LW		 2322 cxix = dopoptosub(cxstack_ix);
2323 if (cxix < 0)
cea2e8a9 2324 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2325 if (cxix < cxstack_ix)
2326 dounwind(cxix);
2327 TOPBLOCK(cx);
2d43a17f 2328 SPAGAIN;
564abe23 2329 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2330 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2331 if (CxREALEVAL(cx))
2332 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2333 else
2334 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2335 }
9850bf21
RH		 2336 else if (CxMULTICALL(cx))
2337 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
d8b46c1b
GS		 2338 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2339 /* put @_ back onto stack */
a0d0e21e 2340 AV* av = cx->blk_sub.argarray;
bfed75c6 2341
93965878 2342 items = AvFILLp(av) + 1;
a45cdc79
DM		 2343 EXTEND(SP, items+1); /* @_ could have been extended. */
2344 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2345 SvREFCNT_dec(GvAV(PL_defgv));
2346 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2347 CLEAR_ARGARRAY(av);
d8b46c1b 2348 /* abandon @_ if it got reified */
62b1ebc2 2349 if (AvREAL(av)) {
b1464ded
DM		 2350 reified = 1;
2351 SvREFCNT_dec(av);
d8b46c1b
GS		 2352 av = newAV();
2353 av_extend(av, items-1);
11ca45c0 2354 AvREIFY_only(av);
dd2155a4 2355 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2356 }
a0d0e21e 2357 }
aed2304a 2358 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
890ce7af 2359 AV* const av = GvAV(PL_defgv);
1fa4e549 2360 items = AvFILLp(av) + 1;
a45cdc79
DM		 2361 EXTEND(SP, items+1); /* @_ could have been extended. */
2362 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2363 }
a45cdc79
DM		 2364 mark = SP;
2365 SP += items;
6b35e009 2366 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2367 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2368 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2369 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2370 LEAVE_SCOPE(oldsave);
2371
2372 /* Now do some callish stuff. */
2373 SAVETMPS;
5023d17a 2374 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
aed2304a 2375 if (CvISXSUB(cv)) {
5eff7df7 2376 OP* retop = cx->blk_sub.retop;
f73ef291
NC		 2377 SV **newsp;
2378 I32 gimme;
b1464ded
DM		 2379 if (reified) {
2380 I32 index;
2381 for (index=0; index<items; index++)
2382 sv_2mortal(SP[-index]);
2383 }
1fa4e549 2384
5eff7df7
DM		 2385 /* XS subs don't have a CxSUB, so pop it */
2386 POPBLOCK(cx, PL_curpm);
1fa4e549 2387 /* Push a mark for the start of arglist */
ac27b0f5 2388 PUSHMARK(mark);
a45cdc79 2389 PUTBACK;
acfe0abc 2390 (void)(*CvXSUB(cv))(aTHX_ cv);
1b6737cc
AL		 2391 /* Put these at the bottom since the vars are set but not used */
2392 PERL_UNUSED_VAR(newsp);
2393 PERL_UNUSED_VAR(gimme);
a0d0e21e 2394 LEAVE;
5eff7df7 2395 return retop;
a0d0e21e
LW		 2396 }
2397 else {
2398 AV* padlist = CvPADLIST(cv);
6b35e009 2399 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2400 PL_in_eval = cx->blk_eval.old_in_eval;
2401 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2402 cx->cx_type = CXt_SUB;
2403 cx->blk_sub.hasargs = 0;
2404 }
a0d0e21e 2405 cx->blk_sub.cv = cv;
1a5b3db4 2406 cx->blk_sub.olddepth = CvDEPTH(cv);
dd2155a4 2407
a0d0e21e
LW		 2408 CvDEPTH(cv)++;
2409 if (CvDEPTH(cv) < 2)
2410 (void)SvREFCNT_inc(cv);
dd2155a4 2411 else {
599cee73 2412 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2413 sub_crush_depth(cv);
26019298 2414 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2415 }
fd617465
DM		 2416 SAVECOMPPAD();
2417 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
6d4ff0d2 2418 if (cx->blk_sub.hasargs)
6d4ff0d2 2419 {
dd2155a4 2420 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2421 SV** ary;
2422
3280af22
NIS		 2423 cx->blk_sub.savearray = GvAV(PL_defgv);
2424 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(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) {
2429 ary = AvALLOC(av);
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);
491527d0 2462 CV *gotocv;
bfed75c6 2463
f398eb67 2464 save_item(sv);
491527d0 2465 if (PERLDB_SUB_NN) {
890ce7af 2466 const int type = SvTYPE(sv);
f398eb67
NC		 2467 if (type < SVt_PVIV && type != SVt_IV)
2468 sv_upgrade(sv, SVt_PVIV);
7619c85e 2469 (void)SvIOK_on(sv);
45977657 2470 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2471 } else {
c445ea15 2472 gv_efullname3(sv, CvGV(cv), NULL);
491527d0
GS		 2473 }
2474 if ( PERLDB_GOTO
864dbfa3 2475 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2476 PUSHMARK( PL_stack_sp );
864dbfa3 2477 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2478 PL_stack_sp--;
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;
a0d0e21e 2632 my_exit(anum);
3280af22 2633 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2634 RETURN;
2635}
2636
a0d0e21e
LW		 2637/* Eval. */
2638
0824fdcb 2639STATIC void
cea2e8a9 2640S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2641{
504618e9 2642 const char *s = SvPVX_const(sv);
890ce7af 2643 const char * const send = SvPVX_const(sv) + SvCUR(sv);
504618e9 2644 I32 line = 1;
a0d0e21e
LW		 2645
2646 while (s && s < send) {
f54cb97a 2647 const char *t;
561b68a9 2648 SV * const tmpstr = newSV(0);
a0d0e21e
LW		 2649
2650 sv_upgrade(tmpstr, SVt_PVMG);
2651 t = strchr(s, '\n');
2652 if (t)
2653 t++;
2654 else
2655 t = send;
2656
2657 sv_setpvn(tmpstr, s, t - s);
2658 av_store(array, line++, tmpstr);
2659 s = t;
2660 }
2661}
2662
901017d6 2663STATIC void
14dd3ad8
GS		 2664S_docatch_body(pTHX)
2665{
97aff369 2666 dVAR;
cea2e8a9 2667 CALLRUNOPS(aTHX);
901017d6 2668 return;
312caa8e
CS		 2669}
2670
0824fdcb 2671STATIC OP *
cea2e8a9 2672S_docatch(pTHX_ OP *o)
1e422769 2673{
97aff369 2674 dVAR;
6224f72b 2675 int ret;
06b5626a 2676 OP * const oldop = PL_op;
db36c5a1 2677 dJMPENV;
1e422769 2678
1e422769 2679#ifdef DEBUGGING
54310121 2680 assert(CATCH_GET == TRUE);
1e422769 2681#endif
312caa8e 2682 PL_op = o;
8bffa5f8 2683
14dd3ad8 2684 JMPENV_PUSH(ret);
6224f72b 2685 switch (ret) {
312caa8e 2686 case 0:
abd70938
DM		 2687 assert(cxstack_ix >= 0);
2688 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2689 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2690 redo_body:
2691 docatch_body();
312caa8e
CS		 2692 break;
2693 case 3:
8bffa5f8 2694 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2695
2696 /* NB XXX we rely on the old popped CxEVAL still being at the top
2697 * of the stack; the way die_where() currently works, this
2698 * assumption is valid. In theory The cur_top_env value should be
2699 * returned in another global, the way retop (aka PL_restartop)
2700 * is. */
2701 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2702
2703 if (PL_restartop
2704 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2705 {
312caa8e
CS		 2706 PL_op = PL_restartop;
2707 PL_restartop = 0;
2708 goto redo_body;
2709 }
2710 /* FALL THROUGH */
2711 default:
14dd3ad8 2712 JMPENV_POP;
533c011a 2713 PL_op = oldop;
6224f72b 2714 JMPENV_JUMP(ret);
1e422769 2715 /* NOTREACHED */
1e422769 2716 }
14dd3ad8 2717 JMPENV_POP;
533c011a 2718 PL_op = oldop;
5f66b61c 2719 return NULL;
1e422769 2720}
2721
c277df42 2722OP *
bfed75c6 2723Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2724/* sv Text to convert to OP tree. */
2725/* startop op_free() this to undo. */
2726/* code Short string id of the caller. */
2727{
f7997f86 2728 /* FIXME - how much of this code is common with pp_entereval? */
27da23d5 2729 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2730 PERL_CONTEXT *cx;
2731 SV **newsp;
b094c71d 2732 I32 gimme = G_VOID;
c277df42
IZ		 2733 I32 optype;
2734 OP dummy;
155aba94 2735 OP *rop;
83ee9e09
GS		 2736 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2737 char *tmpbuf = tbuf;
c277df42 2738 char *safestr;
a3985cdc 2739 int runtime;
601f1833 2740 CV* runcv = NULL; /* initialise to avoid compiler warnings */
f7997f86 2741 STRLEN len;
c277df42
IZ		 2742
2743 ENTER;
2744 lex_start(sv);
2745 SAVETMPS;
2746 /* switch to eval mode */
2747
923e4eb5 2748 if (IN_PERL_COMPILETIME) {
f4dd75d9 2749 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2750 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2751 }
83ee9e09 2752 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
9d4ba2ae 2753 SV * const sv = sv_newmortal();
83ee9e09
GS		 2754 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2755 code, (unsigned long)++PL_evalseq,
2756 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2757 tmpbuf = SvPVX(sv);
fc009855 2758 len = SvCUR(sv);
83ee9e09
GS		 2759 }
2760 else
fc009855
NC		 2761 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2762 (unsigned long)++PL_evalseq);
f4dd75d9 2763 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2764 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2765 SAVECOPLINE(&PL_compiling);
57843af0 2766 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2767 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2768 deleting the eval's FILEGV from the stash before gv_check() runs
2769 (i.e. before run-time proper). To work around the coredump that
2770 ensues, we always turn GvMULTI_on for any globals that were
2771 introduced within evals. See force_ident(). GSAR 96-10-12 */
f7997f86
NC		 2772 safestr = savepvn(tmpbuf, len);
2773 SAVEDELETE(PL_defstash, safestr, len);
b3ac6de7 2774 SAVEHINTS();
d1ca3daa 2775#ifdef OP_IN_REGISTER
6b88bc9c 2776 PL_opsave = op;
d1ca3daa 2777#else
7766f137 2778 SAVEVPTR(PL_op);
d1ca3daa 2779#endif
c277df42 2780
a3985cdc 2781 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2782 runtime = IN_PERL_RUNTIME;
a3985cdc 2783 if (runtime)
d819b83a 2784 runcv = find_runcv(NULL);
a3985cdc 2785
533c011a 2786 PL_op = &dummy;
13b51b79 2787 PL_op->op_type = OP_ENTEREVAL;
533c011a 2788 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2789 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
a0714e2c 2790 PUSHEVAL(cx, 0, NULL);
a3985cdc
DM		 2791
2792 if (runtime)
2793 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2794 else
2795 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2796 POPBLOCK(cx,PL_curpm);
e84b9f1f 2797 POPEVAL(cx);
c277df42
IZ		 2798
2799 (*startop)->op_type = OP_NULL;
22c35a8c 2800 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2801 lex_end();
f3548bdc
DM		 2802 /* XXX DAPM do this properly one year */
2803 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2804 LEAVE;
923e4eb5 2805 if (IN_PERL_COMPILETIME)
eb160463 2806 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2807#ifdef OP_IN_REGISTER
6b88bc9c 2808 op = PL_opsave;
d1ca3daa 2809#endif
9d4ba2ae
AL		 2810 PERL_UNUSED_VAR(newsp);
2811 PERL_UNUSED_VAR(optype);
2812
c277df42
IZ		 2813 return rop;
2814}
2815
a3985cdc
DM		 2816
2817/*
2818=for apidoc find_runcv
2819
2820Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2821If db_seqp is non_null, skip CVs that are in the DB package and populate
2822*db_seqp with the cop sequence number at the point that the DB:: code was
2823entered. (allows debuggers to eval in the scope of the breakpoint rather
cf525c36 2824than in the scope of the debugger itself).
a3985cdc
DM		 2825
2826=cut
2827*/
2828
2829CV*
d819b83a 2830Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2831{
97aff369 2832 dVAR;
a3985cdc 2833 PERL_SI *si;
a3985cdc 2834
d819b83a
DM		 2835 if (db_seqp)
2836 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2837 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2838 I32 ix;
a3985cdc 2839 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2840 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a 2841 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1b6737cc 2842 CV * const cv = cx->blk_sub.cv;
d819b83a
DM		 2843 /* skip DB:: code */
2844 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2845 *db_seqp = cx->blk_oldcop->cop_seq;
2846 continue;
2847 }
2848 return cv;
2849 }
a3985cdc
DM		 2850 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2851 return PL_compcv;
2852 }
2853 }
2854 return PL_main_cv;
2855}
2856
2857
2858/* Compile a require/do, an eval '', or a /(?{...})/.
2859 * In the last case, startop is non-null, and contains the address of
2860 * a pointer that should be set to the just-compiled code.
2861 * outside is the lexically enclosing CV (if any) that invoked us.
2862 */
2863
4d1ff10f 2864/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2865STATIC OP *
a3985cdc 2866S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2867{
27da23d5 2868 dVAR; dSP;
46c461b5 2869 OP * const saveop = PL_op;
a0d0e21e 2870
6dc8a9e4
IZ		 2871 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2872 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2873 : EVAL_INEVAL);
a0d0e21e 2874
1ce6579f 2875 PUSHMARK(SP);
2876
3280af22 2877 SAVESPTR(PL_compcv);
561b68a9 2878 PL_compcv = (CV*)newSV(0);
3280af22 2879 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2880 CvEVAL_on(PL_compcv);
2090ab20
JH		 2881 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2882 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2883
a3985cdc 2884 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2885 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2886
dd2155a4 2887 /* set up a scratch pad */
a0d0e21e 2888
dd2155a4 2889 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2890
07055b4c 2891
26d9b02f 2892 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2893
a0d0e21e
LW		 2894 /* make sure we compile in the right package */
2895
ed094faf 2896 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2897 SAVESPTR(PL_curstash);
ed094faf 2898 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2899 }
3280af22
NIS		 2900 SAVESPTR(PL_beginav);
2901 PL_beginav = newAV();
2902 SAVEFREESV(PL_beginav);
24944567 2903 SAVEI32(PL_error_count);
a0d0e21e
LW		 2904
2905 /* try to compile it */
2906
5f66b61c 2907 PL_eval_root = NULL;
3280af22
NIS		 2908 PL_error_count = 0;
2909 PL_curcop = &PL_compiling;
2910 PL_curcop->cop_arybase = 0;
5f66b61c 2911 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
faef0170 2912 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2913 else
c69006e4 2914 sv_setpvn(ERRSV,"",0);
3280af22 2915 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2916 SV **newsp; /* Used by POPBLOCK. */
9d4ba2ae 2917 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2918 I32 optype = 0; /* Might be reset by POPEVAL. */
9d4ba2ae 2919 const char *msg;
bfed75c6 2920
533c011a 2921 PL_op = saveop;
3280af22
NIS		 2922 if (PL_eval_root) {
2923 op_free(PL_eval_root);
5f66b61c 2924 PL_eval_root = NULL;
a0d0e21e 2925 }
3280af22 2926 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2927 if (!startop) {
3280af22 2928 POPBLOCK(cx,PL_curpm);
c277df42 2929 POPEVAL(cx);
c277df42 2930 }
a0d0e21e
LW		 2931 lex_end();
2932 LEAVE;
9d4ba2ae
AL		 2933
2934 msg = SvPVx_nolen_const(ERRSV);
7a2e2cd6 2935 if (optype == OP_REQUIRE) {
b464bac0 2936 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2937 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2938 &PL_sv_undef, 0);
5a844595
GS		 2939 DIE(aTHX_ "%sCompilation failed in require",
2940 *msg ? msg : "Unknown error\n");
2941 }
2942 else if (startop) {
3280af22 2943 POPBLOCK(cx,PL_curpm);
c277df42 2944 POPEVAL(cx);
5a844595
GS		 2945 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2946 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2947 }
9d7f88dd 2948 else {
9d7f88dd
SR		 2949 if (!*msg) {
2950 sv_setpv(ERRSV, "Compilation error");
2951 }
2952 }
9d4ba2ae 2953 PERL_UNUSED_VAR(newsp);
a0d0e21e
LW		 2954 RETPUSHUNDEF;
2955 }
57843af0 2956 CopLINE_set(&PL_compiling, 0);
c277df42 2957 if (startop) {
3280af22 2958 *startop = PL_eval_root;
c277df42 2959 } else
3280af22 2960 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2961
2962 /* Set the context for this new optree.
2963 * If the last op is an OP_REQUIRE, force scalar context.
2964 * Otherwise, propagate the context from the eval(). */
2965 if (PL_eval_root->op_type == OP_LEAVEEVAL
2966 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2967 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2968 == OP_REQUIRE)
2969 scalar(PL_eval_root);
2970 else if (gimme & G_VOID)
3280af22 2971 scalarvoid(PL_eval_root);
54310121 2972 else if (gimme & G_ARRAY)
3280af22 2973 list(PL_eval_root);
a0d0e21e 2974 else
3280af22 2975 scalar(PL_eval_root);
a0d0e21e
LW		 2976
2977 DEBUG_x(dump_eval());
2978
55497cff 2979 /* Register with debugger: */
84902520 2980 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
890ce7af 2981 CV * const cv = get_cv("DB::postponed", FALSE);
55497cff 2982 if (cv) {
2983 dSP;
924508f0 2984 PUSHMARK(SP);
cc49e20b 2985 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2986 PUTBACK;
864dbfa3 2987 call_sv((SV*)cv, G_DISCARD);
55497cff 2988 }
2989 }
2990
a0d0e21e
LW		 2991 /* compiled okay, so do it */
2992
3280af22
NIS		 2993 CvDEPTH(PL_compcv) = 1;
2994 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2995 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 2996 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 2997
3280af22 2998 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2999}
3000
a6c40364 3001STATIC PerlIO *
ce8abf5f
SP		 3002S_check_type_and_open(pTHX_ const char *name, const char *mode)
3003{
3004 Stat_t st;
c445ea15 3005 const int st_rc = PerlLIO_stat(name, &st);
ce8abf5f 3006 if (st_rc < 0) {
4608196e 3007 return NULL;
ce8abf5f
SP		 3008 }
3009
3010 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3011 Perl_die(aTHX_ "%s %s not allowed in require",
3012 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3013 }
3014 return PerlIO_open(name, mode);
3015}
3016
3017STATIC PerlIO *
7925835c 3018S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3019{
7925835c 3020#ifndef PERL_DISABLE_PMC
f54cb97a 3021 const STRLEN namelen = strlen(name);
b295d113
TH		 3022 PerlIO *fp;
3023
7894fbab 3024 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
9d4ba2ae 3025 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
349d4f2f 3026 const char * const pmc = SvPV_nolen_const(pmcsv);
a6c40364
GS		 3027 Stat_t pmcstat;
3028 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
85e8f315 3029 fp = check_type_and_open(name, mode);
a6c40364
GS		 3030 }
3031 else {
9d4ba2ae 3032 Stat_t pmstat;
b295d113 3033 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3034 pmstat.st_mtime < pmcstat.st_mtime)
3035 {
85e8f315 3036 fp = check_type_and_open(pmc, mode);
a6c40364
GS		 3037 }
3038 else {
85e8f315 3039 fp = check_type_and_open(name, mode);
a6c40364 3040 }
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;
520c758a 3192 (void)SvREFCNT_inc(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;
520c758a 3210 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3211
3212 if (i < count) {
3213 filter_state = SP[i];
520c758a 3214 (void)SvREFCNT_inc(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)
3349 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(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.