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