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