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