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