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