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