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
Upgrade to Math::BigInt 1.75, by Tels
[perl5.git] / pp_ctl.c
CommitLineData
a0d0e21e
LW		 1/* pp_ctl.c
2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
241d1a3b 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
a0d0e21e
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
18 */
19
166f8a29
DM		 20/* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
25 *
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
28 */
29
30
a0d0e21e 31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_PP_CTL_C
a0d0e21e
LW		 33#include "perl.h"
34
35#ifndef WORD_ALIGN
dea28490 36#define WORD_ALIGN sizeof(U32)
a0d0e21e
LW		 37#endif
38
54310121 39#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 40
acfe0abc
GS		 41static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
42
a0d0e21e
LW		 43PP(pp_wantarray)
44{
39644a26 45 dSP;
a0d0e21e
LW		 46 I32 cxix;
47 EXTEND(SP, 1);
48
49 cxix = dopoptosub(cxstack_ix);
50 if (cxix < 0)
51 RETPUSHUNDEF;
52
54310121 53 switch (cxstack[cxix].blk_gimme) {
54 case G_ARRAY:
a0d0e21e 55 RETPUSHYES;
54310121 56 case G_SCALAR:
a0d0e21e 57 RETPUSHNO;
54310121 58 default:
59 RETPUSHUNDEF;
60 }
a0d0e21e
LW		 61}
62
63PP(pp_regcmaybe)
64{
65 return NORMAL;
66}
67
2cd61cdb
IZ		 68PP(pp_regcreset)
69{
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
3280af22 72 PL_reginterp_cnt = 0;
0b4182de 73 TAINT_NOT;
2cd61cdb
IZ		 74 return NORMAL;
75}
76
b3eb6a9b
GS		 77PP(pp_regcomp)
78{
39644a26 79 dSP;
a0d0e21e
LW		 80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
81 register char *t;
82 SV *tmpstr;
83 STRLEN len;
c277df42 84 MAGIC *mg = Null(MAGIC*);
d6ae682c 85
4b5a0d1c 86 /* prevent recompiling under /o and ithreads. */
3db8f154 87#if defined(USE_ITHREADS)
131b3ad0
DM		 88 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
89 if (PL_op->op_flags & OPf_STACKED) {
90 dMARK;
91 SP = MARK;
92 }
93 else
94 (void)POPs;
95 RETURN;
96 }
513629ba 97#endif
131b3ad0
DM		 98 if (PL_op->op_flags & OPf_STACKED) {
99 /* multiple args; concatentate them */
100 dMARK; dORIGMARK;
101 tmpstr = PAD_SV(ARGTARG);
102 sv_setpvn(tmpstr, "", 0);
103 while (++MARK <= SP) {
104 if (PL_amagic_generation) {
105 SV *sv;
106 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
107 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
108 {
109 sv_setsv(tmpstr, sv);
110 continue;
111 }
112 }
113 sv_catsv(tmpstr, *MARK);
114 }
115 SvSETMAGIC(tmpstr);
116 SP = ORIGMARK;
117 }
118 else
119 tmpstr = POPs;
513629ba 120
b3eb6a9b 121 if (SvROK(tmpstr)) {
227a8b4b 122 SV *sv = SvRV(tmpstr);
c277df42 123 if(SvMAGICAL(sv))
14befaf4 124 mg = mg_find(sv, PERL_MAGIC_qr);
c277df42 125 }
b3eb6a9b 126 if (mg) {
c277df42 127 regexp *re = (regexp *)mg->mg_obj;
aaa362c4
RS		 128 ReREFCNT_dec(PM_GETRE(pm));
129 PM_SETRE(pm, ReREFCNT_inc(re));
c277df42
IZ		 130 }
131 else {
132 t = SvPV(tmpstr, len);
133
20408e3c 134 /* Check against the last compiled regexp. */
aaa362c4 135 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
eb160463 136 PM_GETRE(pm)->prelen != (I32)len ||
aaa362c4 137 memNE(PM_GETRE(pm)->precomp, t, len))
85aff577 138 {
aaa362c4 139 if (PM_GETRE(pm)) {
d8f2cf8a 140 ReREFCNT_dec(PM_GETRE(pm));
aaa362c4 141 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
c277df42 142 }
533c011a 143 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 144 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 145
c277df42 146 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
84e09d5e
JH		 147 if (DO_UTF8(tmpstr))
148 pm->op_pmdynflags |= PMdf_DYN_UTF8;
149 else {
150 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
151 if (pm->op_pmdynflags & PMdf_UTF8)
152 t = (char*)bytes_to_utf8((U8*)t, &len);
153 }
aaa362c4 154 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
84e09d5e
JH		 155 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
156 Safefree(t);
f86aaa29 157 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 158 inside tie/overload accessors. */
c277df42 159 }
4633a7c4 160 }
a0d0e21e 161
72311751 162#ifndef INCOMPLETE_TAINTS
3280af22
NIS		 163 if (PL_tainting) {
164 if (PL_tainted)
72311751
GS		 165 pm->op_pmdynflags |= PMdf_TAINTED;
166 else
167 pm->op_pmdynflags &= ~PMdf_TAINTED;
168 }
169#endif
170
aaa362c4 171 if (!PM_GETRE(pm)->prelen && PL_curpm)
3280af22 172 pm = PL_curpm;
17cbf7cc
AMS		 173 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
174 pm->op_pmflags |= PMf_WHITE;
16bdb4ac 175 else
17cbf7cc 176 pm->op_pmflags &= ~PMf_WHITE;
a0d0e21e 177
2360cd68 178 /* XXX runtime compiled output needs to move to the pad */
a0d0e21e 179 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
3db8f154 181#if !defined(USE_ITHREADS)
2360cd68 182 /* XXX can't change the optree at runtime either */
533c011a 183 cLOGOP->op_first->op_next = PL_op->op_next;
2360cd68 184#endif
a0d0e21e
LW		 185 }
186 RETURN;
187}
188
189PP(pp_substcont)
190{
39644a26 191 dSP;
a0d0e21e 192 register PMOP *pm = (PMOP*) cLOGOP->op_other;
c09156bb 193 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
a0d0e21e
LW		 194 register SV *dstr = cx->sb_dstr;
195 register char *s = cx->sb_s;
196 register char *m = cx->sb_m;
197 char *orig = cx->sb_orig;
d9f97599 198 register REGEXP *rx = cx->sb_rx;
db79b45b 199 SV *nsv = Nullsv;
988e6e7e
AE		 200 REGEXP *old = PM_GETRE(pm);
201 if(old != rx) {
d8f2cf8a 202 if(old)
988e6e7e 203 ReREFCNT_dec(old);
d8f2cf8a 204 PM_SETRE(pm,rx);
d8f2cf8a
AB		 205 }
206
d9f97599 207 rxres_restore(&cx->sb_rxres, rx);
a30b2f1f 208 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
c90c0ff4 209
a0d0e21e 210 if (cx->sb_iters++) {
8e5e9ebe 211 I32 saviters = cx->sb_iters;
a0d0e21e 212 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 213 DIE(aTHX_ "Substitution loop");
a0d0e21e 214
48c036b1
GS		 215 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
216 cx->sb_rxtainted |= 2;
a0d0e21e 217 sv_catsv(dstr, POPs);
a0d0e21e
LW		 218
219 /* Are we done */
cea2e8a9 220 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
9661b544 221 s == m, cx->sb_targ, NULL,
22e551b9 222 ((cx->sb_rflags & REXEC_COPY_STR)
cf93c79d
IZ		 223 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
224 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e
LW		 225 {
226 SV *targ = cx->sb_targ;
748a9306 227
078c425b
JH		 228 assert(cx->sb_strend >= s);
229 if(cx->sb_strend > s) {
230 if (DO_UTF8(dstr) && !SvUTF8(targ))
231 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
232 else
233 sv_catpvn(dstr, s, cx->sb_strend - s);
234 }
48c036b1 235 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 236
ed252734
NC		 237#ifdef PERL_COPY_ON_WRITE
238 if (SvIsCOW(targ)) {
239 sv_force_normal_flags(targ, SV_COW_DROP_PV);
240 } else
241#endif
242 {
0c34ef67 243 SvOOK_off(targ);
ed252734
NC		 244 if (SvLEN(targ))
245 Safefree(SvPVX(targ));
246 }
748a9306
LW		 247 SvPVX(targ) = SvPVX(dstr);
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
1aa99e6b
IH		 250 if (DO_UTF8(dstr))
251 SvUTF8_on(targ);
748a9306
LW		 252 SvPVX(dstr) = 0;
253 sv_free(dstr);
48c036b1
GS		 254
255 TAINT_IF(cx->sb_rxtainted & 1);
22e13caa 256 PUSHs(sv_2mortal(newSViv(saviters - 1)));
48c036b1 257
ffc61ed2 258 (void)SvPOK_only_UTF8(targ);
48c036b1 259 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 260 SvSETMAGIC(targ);
9212bbba 261 SvTAINT(targ);
5cd24f17 262
4633a7c4 263 LEAVE_SCOPE(cx->sb_oldsave);
d8f2cf8a 264 ReREFCNT_dec(rx);
a0d0e21e
LW		 265 POPSUBST(cx);
266 RETURNOP(pm->op_next);
267 }
8e5e9ebe 268 cx->sb_iters = saviters;
a0d0e21e 269 }
cf93c79d 270 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 271 m = s;
272 s = orig;
cf93c79d 273 cx->sb_orig = orig = rx->subbeg;
a0d0e21e
LW		 274 s = orig + (m - s);
275 cx->sb_strend = s + (cx->sb_strend - m);
276 }
cf93c79d 277 cx->sb_m = m = rx->startp[0] + orig;
db79b45b
JH		 278 if (m > s) {
279 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
280 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
281 else
282 sv_catpvn(dstr, s, m-s);
283 }
cf93c79d 284 cx->sb_s = rx->endp[0] + orig;
084916e3
JH		 285 { /* Update the pos() information. */
286 SV *sv = cx->sb_targ;
287 MAGIC *mg;
288 I32 i;
289 if (SvTYPE(sv) < SVt_PVMG)
9cbac4c7 290 (void)SvUPGRADE(sv, SVt_PVMG);
14befaf4
DM		 291 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
292 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
293 mg = mg_find(sv, PERL_MAGIC_regex_global);
084916e3
JH		 294 }
295 i = m - orig;
296 if (DO_UTF8(sv))
297 sv_pos_b2u(sv, &i);
298 mg->mg_len = i;
299 }
988e6e7e
AE		 300 if (old != rx)
301 ReREFCNT_inc(rx);
d9f97599
GS		 302 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
303 rxres_save(&cx->sb_rxres, rx);
a0d0e21e
LW		 304 RETURNOP(pm->op_pmreplstart);
305}
306
c90c0ff4 307void
864dbfa3 308Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 309{
310 UV *p = (UV*)*rsp;
311 U32 i;
312
d9f97599 313 if (!p || p[1] < rx->nparens) {
ed252734
NC		 314#ifdef PERL_COPY_ON_WRITE
315 i = 7 + rx->nparens * 2;
316#else
d9f97599 317 i = 6 + rx->nparens * 2;
ed252734 318#endif
c90c0ff4 319 if (!p)
320 New(501, p, i, UV);
321 else
322 Renew(p, i, UV);
323 *rsp = (void*)p;
324 }
325
56431972 326 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
cf93c79d 327 RX_MATCH_COPIED_off(rx);
c90c0ff4 328
ed252734
NC		 329#ifdef PERL_COPY_ON_WRITE
330 *p++ = PTR2UV(rx->saved_copy);
331 rx->saved_copy = Nullsv;
332#endif
333
d9f97599 334 *p++ = rx->nparens;
c90c0ff4 335
56431972 336 *p++ = PTR2UV(rx->subbeg);
cf93c79d 337 *p++ = (UV)rx->sublen;
d9f97599
GS		 338 for (i = 0; i <= rx->nparens; ++i) {
339 *p++ = (UV)rx->startp[i];
340 *p++ = (UV)rx->endp[i];
c90c0ff4 341 }
342}
343
344void
864dbfa3 345Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 346{
347 UV *p = (UV*)*rsp;
348 U32 i;
349
ed252734 350 RX_MATCH_COPY_FREE(rx);
cf93c79d 351 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4 352 *p++ = 0;
353
ed252734
NC		 354#ifdef PERL_COPY_ON_WRITE
355 if (rx->saved_copy)
356 SvREFCNT_dec (rx->saved_copy);
357 rx->saved_copy = INT2PTR(SV*,*p);
358 *p++ = 0;
359#endif
360
d9f97599 361 rx->nparens = *p++;
c90c0ff4 362
56431972 363 rx->subbeg = INT2PTR(char*,*p++);
cf93c79d 364 rx->sublen = (I32)(*p++);
d9f97599 365 for (i = 0; i <= rx->nparens; ++i) {
cf93c79d
IZ		 366 rx->startp[i] = (I32)(*p++);
367 rx->endp[i] = (I32)(*p++);
c90c0ff4 368 }
369}
370
371void
864dbfa3 372Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 373{
374 UV *p = (UV*)*rsp;
375
376 if (p) {
56431972 377 Safefree(INT2PTR(char*,*p));
ed252734
NC		 378#ifdef PERL_COPY_ON_WRITE
379 if (p[1]) {
380 SvREFCNT_dec (INT2PTR(SV*,p[1]));
381 }
382#endif
c90c0ff4 383 Safefree(p);
384 *rsp = Null(void*);
385 }
386}
387
a0d0e21e
LW		 388PP(pp_formline)
389{
39644a26 390 dSP; dMARK; dORIGMARK;
76e3520e 391 register SV *tmpForm = *++MARK;
dea28490 392 register U32 *fpc;
a0d0e21e
LW		 393 register char *t;
394 register char *f;
395 register char *s;
396 register char *send;
397 register I32 arg;
9c5ffd7c
JH		 398 register SV *sv = Nullsv;
399 char *item = Nullch;
400 I32 itemsize = 0;
401 I32 fieldsize = 0;
a0d0e21e 402 I32 lines = 0;
3280af22 403 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
9c5ffd7c
JH		 404 char *chophere = Nullch;
405 char *linemark = Nullch;
65202027 406 NV value;
9c5ffd7c 407 bool gotsome = FALSE;
a0d0e21e 408 STRLEN len;
24c89738
DM		 409 STRLEN fudge = SvPOK(tmpForm)
410 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
1bd51a4c
IH		 411 bool item_is_utf8 = FALSE;
412 bool targ_is_utf8 = FALSE;
78da4d13 413 SV * nsv = Nullsv;
a1b95068
WL		 414 OP * parseres = 0;
415 char *fmt;
416 bool oneline;
a0d0e21e 417
76e3520e 418 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445b3f51
GS		 419 if (SvREADONLY(tmpForm)) {
420 SvREADONLY_off(tmpForm);
a1b95068 421 parseres = doparseform(tmpForm);
445b3f51
GS		 422 SvREADONLY_on(tmpForm);
423 }
424 else
a1b95068
WL		 425 parseres = doparseform(tmpForm);
426 if (parseres)
427 return parseres;
a0d0e21e 428 }
3280af22 429 SvPV_force(PL_formtarget, len);
1bd51a4c
IH		 430 if (DO_UTF8(PL_formtarget))
431 targ_is_utf8 = TRUE;
a0ed51b3 432 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 433 t += len;
76e3520e 434 f = SvPV(tmpForm, len);
a0d0e21e 435 /* need to jump to the next word */
76e3520e 436 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
a0d0e21e 437
dea28490 438 fpc = (U32*)s;
a0d0e21e
LW		 439
440 for (;;) {
441 DEBUG_f( {
442 char *name = "???";
443 arg = -1;
444 switch (*fpc) {
445 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
446 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
447 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
448 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
449 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
450
451 case FF_CHECKNL: name = "CHECKNL"; break;
452 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
453 case FF_SPACE: name = "SPACE"; break;
454 case FF_HALFSPACE: name = "HALFSPACE"; break;
455 case FF_ITEM: name = "ITEM"; break;
456 case FF_CHOP: name = "CHOP"; break;
457 case FF_LINEGLOB: name = "LINEGLOB"; break;
458 case FF_NEWLINE: name = "NEWLINE"; break;
459 case FF_MORE: name = "MORE"; break;
460 case FF_LINEMARK: name = "LINEMARK"; break;
461 case FF_END: name = "END"; break;
784707d5 462 case FF_0DECIMAL: name = "0DECIMAL"; break;
a1b95068 463 case FF_LINESNGL: name = "LINESNGL"; break;
a0d0e21e
LW		 464 }
465 if (arg >= 0)
bf49b057 466 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 467 else
bf49b057 468 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
5f80b19c 469 } );
a0d0e21e
LW		 470 switch (*fpc++) {
471 case FF_LINEMARK:
472 linemark = t;
a0d0e21e
LW		 473 lines++;
474 gotsome = FALSE;
475 break;
476
477 case FF_LITERAL:
478 arg = *fpc++;
1bd51a4c 479 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
78da4d13
JH		 480 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
481 *t = '\0';
482 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
483 t = SvEND(PL_formtarget);
1bd51a4c
IH		 484 break;
485 }
486 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
487 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
488 *t = '\0';
489 sv_utf8_upgrade(PL_formtarget);
490 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
491 t = SvEND(PL_formtarget);
492 targ_is_utf8 = TRUE;
493 }
a0d0e21e
LW		 494 while (arg--)
495 *t++ = *f++;
496 break;
497
498 case FF_SKIP:
499 f += *fpc++;
500 break;
501
502 case FF_FETCH:
503 arg = *fpc++;
504 f += arg;
505 fieldsize = arg;
506
507 if (MARK < SP)
508 sv = *++MARK;
509 else {
3280af22 510 sv = &PL_sv_no;
599cee73 511 if (ckWARN(WARN_SYNTAX))
9014280d 512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
a0d0e21e
LW		 513 }
514 break;
515
516 case FF_CHECKNL:
517 item = s = SvPV(sv, len);
518 itemsize = len;
7e2040f0 519 if (DO_UTF8(sv)) {
a0ed51b3 520 itemsize = sv_len_utf8(sv);
eb160463 521 if (itemsize != (I32)len) {
a0ed51b3
LW		 522 I32 itembytes;
523 if (itemsize > fieldsize) {
524 itemsize = fieldsize;
525 itembytes = itemsize;
526 sv_pos_u2b(sv, &itembytes, 0);
527 }
528 else
529 itembytes = len;
530 send = chophere = s + itembytes;
531 while (s < send) {
532 if (*s & ~31)
533 gotsome = TRUE;
534 else if (*s == '\n')
535 break;
536 s++;
537 }
1bd51a4c 538 item_is_utf8 = TRUE;
a0ed51b3
LW		 539 itemsize = s - item;
540 sv_pos_b2u(sv, &itemsize);
541 break;
542 }
543 }
1bd51a4c 544 item_is_utf8 = FALSE;
a0d0e21e
LW		 545 if (itemsize > fieldsize)
546 itemsize = fieldsize;
547 send = chophere = s + itemsize;
548 while (s < send) {
549 if (*s & ~31)
550 gotsome = TRUE;
551 else if (*s == '\n')
552 break;
553 s++;
554 }
555 itemsize = s - item;
556 break;
557
558 case FF_CHECKCHOP:
559 item = s = SvPV(sv, len);
560 itemsize = len;
7e2040f0 561 if (DO_UTF8(sv)) {
a0ed51b3 562 itemsize = sv_len_utf8(sv);
eb160463 563 if (itemsize != (I32)len) {
a0ed51b3
LW		 564 I32 itembytes;
565 if (itemsize <= fieldsize) {
566 send = chophere = s + itemsize;
567 while (s < send) {
568 if (*s == '\r') {
569 itemsize = s - item;
a1b95068 570 chophere = s;
a0ed51b3
LW		 571 break;
572 }
573 if (*s++ & ~31)
574 gotsome = TRUE;
575 }
576 }
577 else {
578 itemsize = fieldsize;
579 itembytes = itemsize;
580 sv_pos_u2b(sv, &itembytes, 0);
581 send = chophere = s + itembytes;
582 while (s < send || (s == send && isSPACE(*s))) {
583 if (isSPACE(*s)) {
584 if (chopspace)
585 chophere = s;
586 if (*s == '\r')
587 break;
588 }
589 else {
590 if (*s & ~31)
591 gotsome = TRUE;
592 if (strchr(PL_chopset, *s))
593 chophere = s + 1;
594 }
595 s++;
596 }
597 itemsize = chophere - item;
598 sv_pos_b2u(sv, &itemsize);
599 }
1bd51a4c 600 item_is_utf8 = TRUE;
a0ed51b3
LW		 601 break;
602 }
603 }
1bd51a4c 604 item_is_utf8 = FALSE;
a0d0e21e
LW		 605 if (itemsize <= fieldsize) {
606 send = chophere = s + itemsize;
607 while (s < send) {
608 if (*s == '\r') {
609 itemsize = s - item;
a1b95068 610 chophere = s;
a0d0e21e
LW		 611 break;
612 }
613 if (*s++ & ~31)
614 gotsome = TRUE;
615 }
616 }
617 else {
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
621 if (isSPACE(*s)) {
622 if (chopspace)
623 chophere = s;
624 if (*s == '\r')
625 break;
626 }
627 else {
628 if (*s & ~31)
629 gotsome = TRUE;
3280af22 630 if (strchr(PL_chopset, *s))
a0d0e21e
LW		 631 chophere = s + 1;
632 }
633 s++;
634 }
635 itemsize = chophere - item;
636 }
637 break;
638
639 case FF_SPACE:
640 arg = fieldsize - itemsize;
641 if (arg) {
642 fieldsize -= arg;
643 while (arg-- > 0)
644 *t++ = ' ';
645 }
646 break;
647
648 case FF_HALFSPACE:
649 arg = fieldsize - itemsize;
650 if (arg) {
651 arg /= 2;
652 fieldsize -= arg;
653 while (arg-- > 0)
654 *t++ = ' ';
655 }
656 break;
657
658 case FF_ITEM:
659 arg = itemsize;
660 s = item;
1bd51a4c
IH		 661 if (item_is_utf8) {
662 if (!targ_is_utf8) {
663 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
664 *t = '\0';
665 sv_utf8_upgrade(PL_formtarget);
666 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
667 t = SvEND(PL_formtarget);
668 targ_is_utf8 = TRUE;
669 }
a0ed51b3 670 while (arg--) {
fd400ab9 671 if (UTF8_IS_CONTINUED(*s)) {
63cd0674
NIS		 672 STRLEN skip = UTF8SKIP(s);
673 switch (skip) {
674 default:
675 Move(s,t,skip,char);
676 s += skip;
677 t += skip;
678 break;
a0ed51b3
LW		 679 case 7: *t++ = *s++;
680 case 6: *t++ = *s++;
681 case 5: *t++ = *s++;
682 case 4: *t++ = *s++;
683 case 3: *t++ = *s++;
684 case 2: *t++ = *s++;
685 case 1: *t++ = *s++;
686 }
687 }
688 else {
689 if ( !((*t++ = *s++) & ~31) )
690 t[-1] = ' ';
691 }
692 }
693 break;
694 }
78da4d13
JH		 695 if (targ_is_utf8 && !item_is_utf8) {
696 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
697 *t = '\0';
698 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
699 for (; t < SvEND(PL_formtarget); t++) {
700#ifdef EBCDIC
a1b95068 701 int ch = *t;
78da4d13
JH		 702 if (iscntrl(ch))
703#else
704 if (!(*t & ~31))
705#endif
706 *t = ' ';
707 }
708 break;
709 }
a0d0e21e 710 while (arg--) {
9d116dd7 711#ifdef EBCDIC
a0d0e21e 712 int ch = *t++ = *s++;
9d116dd7 713 if (iscntrl(ch))
a0d0e21e
LW		 714#else
715 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 716#endif
9d116dd7 717 t[-1] = ' ';
a0d0e21e
LW		 718 }
719 break;
720
721 case FF_CHOP:
722 s = chophere;
723 if (chopspace) {
724 while (*s && isSPACE(*s))
725 s++;
726 }
727 sv_chop(sv,s);
ea42cebc 728 SvSETMAGIC(sv);
a0d0e21e
LW		 729 break;
730
a1b95068
WL		 731 case FF_LINESNGL:
732 chopspace = 0;
733 oneline = TRUE;
734 goto ff_line;
a0d0e21e 735 case FF_LINEGLOB:
a1b95068
WL		 736 oneline = FALSE;
737 ff_line:
a0d0e21e
LW		 738 item = s = SvPV(sv, len);
739 itemsize = len;
1bd51a4c
IH		 740 if ((item_is_utf8 = DO_UTF8(sv)))
741 itemsize = sv_len_utf8(sv);
a0d0e21e 742 if (itemsize) {
1bd51a4c 743 bool chopped = FALSE;
a0d0e21e 744 gotsome = TRUE;
1bd51a4c 745 send = s + len;
a1b95068 746 chophere = s + itemsize;
a0d0e21e
LW		 747 while (s < send) {
748 if (*s++ == '\n') {
a1b95068 749 if (oneline) {
1bd51a4c 750 chopped = TRUE;
a1b95068
WL		 751 chophere = s;
752 break;
753 } else {
754 if (s == send) {
755 itemsize--;
756 chopped = TRUE;
757 } else
758 lines++;
1bd51a4c 759 }
a0d0e21e
LW		 760 }
761 }
3280af22 762 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
1bd51a4c
IH		 763 if (targ_is_utf8)
764 SvUTF8_on(PL_formtarget);
a1b95068
WL		 765 if (oneline) {
766 SvCUR_set(sv, chophere - item);
767 sv_catsv(PL_formtarget, sv);
768 SvCUR_set(sv, itemsize);
769 } else
770 sv_catsv(PL_formtarget, sv);
1bd51a4c
IH		 771 if (chopped)
772 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
a0ed51b3 773 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
3280af22 774 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
1bd51a4c
IH		 775 if (item_is_utf8)
776 targ_is_utf8 = TRUE;
a0d0e21e
LW		 777 }
778 break;
779
a1b95068
WL		 780 case FF_0DECIMAL:
781 arg = *fpc++;
782#if defined(USE_LONG_DOUBLE)
783 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
784#else
785 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
786#endif
787 goto ff_dec;
a0d0e21e 788 case FF_DECIMAL:
a0d0e21e 789 arg = *fpc++;
65202027 790#if defined(USE_LONG_DOUBLE)
a1b95068 791 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
65202027 792#else
a1b95068 793 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
65202027 794#endif
a1b95068 795 ff_dec:
784707d5
JP		 796 /* If the field is marked with ^ and the value is undefined,
797 blank it out. */
784707d5
JP		 798 if ((arg & 512) && !SvOK(sv)) {
799 arg = fieldsize;
800 while (arg--)
801 *t++ = ' ';
802 break;
803 }
804 gotsome = TRUE;
805 value = SvNV(sv);
a1b95068
WL		 806 /* overflow evidence */
807 if (num_overflow(value, fieldsize, arg)) {
808 arg = fieldsize;
809 while (arg--)
810 *t++ = '#';
811 break;
812 }
784707d5
JP		 813 /* Formats aren't yet marked for locales, so assume "yes". */
814 {
815 STORE_NUMERIC_STANDARD_SET_LOCAL();
a1b95068 816 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
784707d5
JP		 817 RESTORE_NUMERIC_STANDARD();
818 }
819 t += fieldsize;
820 break;
a1b95068 821
a0d0e21e
LW		 822 case FF_NEWLINE:
823 f++;
824 while (t-- > linemark && *t == ' ') ;
825 t++;
826 *t++ = '\n';
827 break;
828
829 case FF_BLANK:
830 arg = *fpc++;
831 if (gotsome) {
832 if (arg) { /* repeat until fields exhausted? */
833 *t = '\0';
3280af22
NIS		 834 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
835 lines += FmLINES(PL_formtarget);
a0d0e21e
LW		 836 if (lines == 200) {
837 arg = t - linemark;
838 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 839 DIE(aTHX_ "Runaway format");
a0d0e21e 840 }
1bd51a4c
IH		 841 if (targ_is_utf8)
842 SvUTF8_on(PL_formtarget);
3280af22 843 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW		 844 SP = ORIGMARK;
845 RETURNOP(cLISTOP->op_first);
846 }
847 }
848 else {
849 t = linemark;
850 lines--;
851 }
852 break;
853
854 case FF_MORE:
7056ecde
KM		 855 s = chophere;
856 send = item + len;
857 if (chopspace) {
858 while (*s && isSPACE(*s) && s < send)
859 s++;
860 }
861 if (s < send) {
a0d0e21e
LW		 862 arg = fieldsize - itemsize;
863 if (arg) {
864 fieldsize -= arg;
865 while (arg-- > 0)
866 *t++ = ' ';
867 }
868 s = t - 3;
869 if (strnEQ(s," ",3)) {
3280af22 870 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
a0d0e21e
LW		 871 s--;
872 }
873 *s++ = '.';
874 *s++ = '.';
875 *s++ = '.';
876 }
877 break;
878
879 case FF_END:
880 *t = '\0';
3280af22 881 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
1bd51a4c
IH		 882 if (targ_is_utf8)
883 SvUTF8_on(PL_formtarget);
3280af22 884 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW		 885 SP = ORIGMARK;
886 RETPUSHYES;
887 }
888 }
889}
890
891PP(pp_grepstart)
892{
39644a26 893 dSP;
a0d0e21e
LW		 894 SV *src;
895
3280af22 896 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 897 (void)POPMARK;
54310121 898 if (GIMME_V == G_SCALAR)
0b024f31 899 XPUSHs(sv_2mortal(newSViv(0)));
533c011a 900 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 901 }
3280af22 902 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS		 903 pp_pushmark(); /* push dst */
904 pp_pushmark(); /* push src */
a0d0e21e
LW		 905 ENTER; /* enter outer scope */
906
907 SAVETMPS;
59f00321
RGS		 908 if (PL_op->op_private & OPpGREP_LEX)
909 SAVESPTR(PAD_SVl(PL_op->op_targ));
910 else
911 SAVE_DEFSV;
a0d0e21e 912 ENTER; /* enter inner scope */
7766f137 913 SAVEVPTR(PL_curpm);
a0d0e21e 914
3280af22 915 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 916 SvTEMP_off(src);
59f00321
RGS		 917 if (PL_op->op_private & OPpGREP_LEX)
918 PAD_SVl(PL_op->op_targ) = src;
919 else
920 DEFSV = src;
a0d0e21e
LW		 921
922 PUTBACK;
533c011a 923 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 924 pp_pushmark(); /* push top */
533c011a 925 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 926}
927
928PP(pp_mapstart)
929{
cea2e8a9 930 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
a0d0e21e
LW		 931}
932
933PP(pp_mapwhile)
934{
39644a26 935 dSP;
4c90a460 936 I32 gimme = GIMME_V;
544f3153 937 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
a0d0e21e
LW		 938 I32 count;
939 I32 shift;
940 SV** src;
ac27b0f5 941 SV** dst;
a0d0e21e 942
544f3153 943 /* first, move source pointer to the next item in the source list */
3280af22 944 ++PL_markstack_ptr[-1];
544f3153
GS		 945
946 /* if there are new items, push them into the destination list */
4c90a460 947 if (items && gimme != G_VOID) {
544f3153
GS		 948 /* might need to make room back there first */
949 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
950 /* XXX this implementation is very pessimal because the stack
951 * is repeatedly extended for every set of items. Is possible
952 * to do this without any stack extension or copying at all
953 * by maintaining a separate list over which the map iterates
18ef8bea 954 * (like foreach does). --gsar */
544f3153
GS		 955
956 /* everything in the stack after the destination list moves
957 * towards the end the stack by the amount of room needed */
958 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
959
960 /* items to shift up (accounting for the moved source pointer) */
961 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
18ef8bea
BT		 962
963 /* This optimization is by Ben Tilly and it does
964 * things differently from what Sarathy (gsar)
965 * is describing. The downside of this optimization is
966 * that leaves "holes" (uninitialized and hopefully unused areas)
967 * to the Perl stack, but on the other hand this
968 * shouldn't be a problem. If Sarathy's idea gets
969 * implemented, this optimization should become
970 * irrelevant. --jhi */
971 if (shift < count)
972 shift = count; /* Avoid shifting too often --Ben Tilly */
ac27b0f5 973
924508f0
GS		 974 EXTEND(SP,shift);
975 src = SP;
976 dst = (SP += shift);
3280af22
NIS		 977 PL_markstack_ptr[-1] += shift;
978 *PL_markstack_ptr += shift;
544f3153 979 while (count--)
a0d0e21e
LW		 980 *dst-- = *src--;
981 }
544f3153 982 /* copy the new items down to the destination list */
ac27b0f5 983 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
22023b26
TP		 984 if (gimme == G_ARRAY) {
985 while (items-- > 0)
986 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
987 }
988 else {
989 /* scalar context: we don't care about which values map returns
990 * (we use undef here). And so we certainly don't want to do mortal
991 * copies of meaningless values. */
992 while (items-- > 0) {
b988aa42 993 (void)POPs;
22023b26
TP		 994 *dst-- = &PL_sv_undef;
995 }
996 }
a0d0e21e
LW		 997 }
998 LEAVE; /* exit inner scope */
999
1000 /* All done yet? */
3280af22 1001 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e
LW		 1002
1003 (void)POPMARK; /* pop top */
1004 LEAVE; /* exit outer scope */
1005 (void)POPMARK; /* pop src */
3280af22 1006 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 1007 (void)POPMARK; /* pop dst */
3280af22 1008 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 1009 if (gimme == G_SCALAR) {
7cc47870
RGS		 1010 if (PL_op->op_private & OPpGREP_LEX) {
1011 SV* sv = sv_newmortal();
1012 sv_setiv(sv, items);
1013 PUSHs(sv);
1014 }
1015 else {
1016 dTARGET;
1017 XPUSHi(items);
1018 }
a0d0e21e 1019 }
54310121 1020 else if (gimme == G_ARRAY)
1021 SP += items;
a0d0e21e
LW		 1022 RETURN;
1023 }
1024 else {
1025 SV *src;
1026
1027 ENTER; /* enter inner scope */
7766f137 1028 SAVEVPTR(PL_curpm);
a0d0e21e 1029
544f3153 1030 /* set $_ to the new source item */
3280af22 1031 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 1032 SvTEMP_off(src);
59f00321
RGS		 1033 if (PL_op->op_private & OPpGREP_LEX)
1034 PAD_SVl(PL_op->op_targ) = src;
1035 else
1036 DEFSV = src;
a0d0e21e
LW		 1037
1038 RETURNOP(cLOGOP->op_other);
1039 }
1040}
1041
a0d0e21e
LW		 1042/* Range stuff. */
1043
1044PP(pp_range)
1045{
1046 if (GIMME == G_ARRAY)
1a67a97c 1047 return NORMAL;
538573f7 1048 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 1049 return cLOGOP->op_other;
538573f7 1050 else
1a67a97c 1051 return NORMAL;
a0d0e21e
LW		 1052}
1053
1054PP(pp_flip)
1055{
39644a26 1056 dSP;
a0d0e21e
LW		 1057
1058 if (GIMME == G_ARRAY) {
1a67a97c 1059 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1060 }
1061 else {
1062 dTOPss;
533c011a 1063 SV *targ = PAD_SV(PL_op->op_targ);
4e3399f9 1064 int flip = 0;
790090df
HS		 1065
1066 if (PL_op->op_private & OPpFLIP_LINENUM) {
4e3399f9
YST		 1067 if (GvIO(PL_last_in_gv)) {
1068 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1069 }
1070 else {
1071 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1072 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1073 }
790090df
HS		 1074 } else {
1075 flip = SvTRUE(sv);
1076 }
1077 if (flip) {
a0d0e21e 1078 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1079 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1080 sv_setiv(targ, 1);
3e3baf6d 1081 SETs(targ);
a0d0e21e
LW		 1082 RETURN;
1083 }
1084 else {
1085 sv_setiv(targ, 0);
924508f0 1086 SP--;
1a67a97c 1087 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 1088 }
1089 }
1090 sv_setpv(TARG, "");
1091 SETs(targ);
1092 RETURN;
1093 }
1094}
1095
8e9bbdb9
RGS		 1096/* This code tries to decide if "$left .. $right" should use the
1097 magical string increment, or if the range is numeric (we make
1098 an exception for .."0" [#18165]). AMS 20021031. */
1099
1100#define RANGE_IS_NUMERIC(left,right) ( \
b0e74086
RGS		 1101 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1102 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
e0ab1c0e
MHM		 1103 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1104 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1105 && (!SvOK(right) || looks_like_number(right))))
8e9bbdb9 1106
a0d0e21e
LW		 1107PP(pp_flop)
1108{
39644a26 1109 dSP;
a0d0e21e
LW		 1110
1111 if (GIMME == G_ARRAY) {
1112 dPOPPOPssrl;
4fe3f0fa 1113 register IV i, j;
a0d0e21e 1114 register SV *sv;
4fe3f0fa 1115 IV max;
86cb7173
HS		 1116
1117 if (SvGMAGICAL(left))
1118 mg_get(left);
1119 if (SvGMAGICAL(right))
1120 mg_get(right);
a0d0e21e 1121
8e9bbdb9 1122 if (RANGE_IS_NUMERIC(left,right)) {
4fe3f0fa
MHM		 1123 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1124 (SvOK(right) && SvNV(right) > IV_MAX))
d470f89e 1125 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1126 i = SvIV(left);
1127 max = SvIV(right);
bbce6d69 1128 if (max >= i) {
c1ab3db2
AK		 1129 j = max - i + 1;
1130 EXTEND_MORTAL(j);
1131 EXTEND(SP, j);
bbce6d69 1132 }
c1ab3db2
AK		 1133 else
1134 j = 0;
1135 while (j--) {
bbce6d69 1136 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1137 PUSHs(sv);
1138 }
1139 }
1140 else {
1141 SV *final = sv_mortalcopy(right);
2d8e6c8d 1142 STRLEN len, n_a;
a0d0e21e
LW		 1143 char *tmps = SvPV(final, len);
1144
1145 sv = sv_mortalcopy(left);
2d8e6c8d 1146 SvPV_force(sv,n_a);
89ea2908 1147 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1148 XPUSHs(sv);
89ea2908
GA		 1149 if (strEQ(SvPVX(sv),tmps))
1150 break;
a0d0e21e
LW		 1151 sv = sv_2mortal(newSVsv(sv));
1152 sv_inc(sv);
1153 }
a0d0e21e
LW		 1154 }
1155 }
1156 else {
1157 dTOPss;
1158 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
4e3399f9 1159 int flop = 0;
a0d0e21e 1160 sv_inc(targ);
4e3399f9
YST		 1161
1162 if (PL_op->op_private & OPpFLIP_LINENUM) {
1163 if (GvIO(PL_last_in_gv)) {
1164 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1165 }
1166 else {
1167 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1168 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1169 }
1170 }
1171 else {
1172 flop = SvTRUE(sv);
1173 }
1174
1175 if (flop) {
a0d0e21e
LW		 1176 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1177 sv_catpv(targ, "E0");
1178 }
1179 SETs(targ);
1180 }
1181
1182 RETURN;
1183}
1184
1185/* Control. */
1186
515afda2
NC		 1187static char *context_name[] = {
1188 "pseudo-block",
1189 "subroutine",
1190 "eval",
1191 "loop",
1192 "substitution",
1193 "block",
1194 "format"
1195};
1196
76e3520e 1197STATIC I32
cea2e8a9 1198S_dopoptolabel(pTHX_ char *label)
a0d0e21e
LW		 1199{
1200 register I32 i;
c09156bb 1201 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1202
1203 for (i = cxstack_ix; i >= 0; i--) {
1204 cx = &cxstack[i];
6b35e009 1205 switch (CxTYPE(cx)) {
a0d0e21e 1206 case CXt_SUBST:
a0d0e21e 1207 case CXt_SUB:
7766f137 1208 case CXt_FORMAT:
a0d0e21e 1209 case CXt_EVAL:
0a753a76 1210 case CXt_NULL:
e476b1b5 1211 if (ckWARN(WARN_EXITING))
515afda2
NC		 1212 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1213 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1214 if (CxTYPE(cx) == CXt_NULL)
1215 return -1;
1216 break;
a0d0e21e
LW		 1217 case CXt_LOOP:
1218 if (!cx->blk_loop.label ||
1219 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1221 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1222 continue;
1223 }
cea2e8a9 1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1225 return i;
1226 }
1227 }
1228 return i;
1229}
1230
e50aee73 1231I32
864dbfa3 1232Perl_dowantarray(pTHX)
e50aee73 1233{
54310121 1234 I32 gimme = block_gimme();
1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1236}
1237
1238I32
864dbfa3 1239Perl_block_gimme(pTHX)
54310121 1240{
e50aee73
AD		 1241 I32 cxix;
1242
1243 cxix = dopoptosub(cxstack_ix);
1244 if (cxix < 0)
46fc3d4c 1245 return G_VOID;
e50aee73 1246
54310121 1247 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1248 case G_VOID:
1249 return G_VOID;
54310121 1250 case G_SCALAR:
e50aee73 1251 return G_SCALAR;
54310121 1252 case G_ARRAY:
1253 return G_ARRAY;
1254 default:
cea2e8a9 1255 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1256 /* NOTREACHED */
1257 return 0;
54310121 1258 }
e50aee73
AD		 1259}
1260
78f9721b
SM		 1261I32
1262Perl_is_lvalue_sub(pTHX)
1263{
1264 I32 cxix;
1265
1266 cxix = dopoptosub(cxstack_ix);
1267 assert(cxix >= 0); /* We should only be called from inside subs */
1268
1269 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1270 return cxstack[cxix].blk_sub.lval;
1271 else
1272 return 0;
1273}
1274
76e3520e 1275STATIC I32
cea2e8a9 1276S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1277{
2c375eb9
GS		 1278 return dopoptosub_at(cxstack, startingblock);
1279}
1280
1281STATIC I32
cea2e8a9 1282S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9 1283{
a0d0e21e 1284 I32 i;
c09156bb 1285 register PERL_CONTEXT *cx;
a0d0e21e 1286 for (i = startingblock; i >= 0; i--) {
2c375eb9 1287 cx = &cxstk[i];
6b35e009 1288 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1289 default:
1290 continue;
1291 case CXt_EVAL:
1292 case CXt_SUB:
7766f137 1293 case CXt_FORMAT:
cea2e8a9 1294 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1295 return i;
1296 }
1297 }
1298 return i;
1299}
1300
76e3520e 1301STATIC I32
cea2e8a9 1302S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e
LW		 1303{
1304 I32 i;
c09156bb 1305 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1306 for (i = startingblock; i >= 0; i--) {
1307 cx = &cxstack[i];
6b35e009 1308 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1309 default:
1310 continue;
1311 case CXt_EVAL:
cea2e8a9 1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1313 return i;
1314 }
1315 }
1316 return i;
1317}
1318
76e3520e 1319STATIC I32
cea2e8a9 1320S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e
LW		 1321{
1322 I32 i;
c09156bb 1323 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1324 for (i = startingblock; i >= 0; i--) {
1325 cx = &cxstack[i];
6b35e009 1326 switch (CxTYPE(cx)) {
a0d0e21e 1327 case CXt_SUBST:
a0d0e21e 1328 case CXt_SUB:
7766f137 1329 case CXt_FORMAT:
a0d0e21e 1330 case CXt_EVAL:
0a753a76 1331 case CXt_NULL:
e476b1b5 1332 if (ckWARN(WARN_EXITING))
515afda2
NC		 1333 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335 if ((CxTYPE(cx)) == CXt_NULL)
1336 return -1;
1337 break;
a0d0e21e 1338 case CXt_LOOP:
cea2e8a9 1339 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1340 return i;
1341 }
1342 }
1343 return i;
1344}
1345
1346void
864dbfa3 1347Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1348{
c09156bb 1349 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1350 I32 optype;
1351
1352 while (cxstack_ix > cxix) {
b0d9ce38 1353 SV *sv;
c90c0ff4 1354 cx = &cxstack[cxstack_ix];
1355 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1356 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1357 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1358 switch (CxTYPE(cx)) {
c90c0ff4 1359 case CXt_SUBST:
1360 POPSUBST(cx);
1361 continue; /* not break */
a0d0e21e 1362 case CXt_SUB:
b0d9ce38
GS		 1363 POPSUB(cx,sv);
1364 LEAVESUB(sv);
a0d0e21e
LW		 1365 break;
1366 case CXt_EVAL:
1367 POPEVAL(cx);
1368 break;
1369 case CXt_LOOP:
1370 POPLOOP(cx);
1371 break;
0a753a76 1372 case CXt_NULL:
a0d0e21e 1373 break;
7766f137
GS		 1374 case CXt_FORMAT:
1375 POPFORMAT(cx);
1376 break;
a0d0e21e 1377 }
c90c0ff4 1378 cxstack_ix--;
a0d0e21e
LW		 1379 }
1380}
1381
5a844595
GS		 1382void
1383Perl_qerror(pTHX_ SV *err)
1384{
1385 if (PL_in_eval)
1386 sv_catsv(ERRSV, err);
1387 else if (PL_errors)
1388 sv_catsv(PL_errors, err);
1389 else
894356b3 1390 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS		 1391 ++PL_error_count;
1392}
1393
a0d0e21e 1394OP *
35a4481c 1395Perl_die_where(pTHX_ const char *message, STRLEN msglen)
a0d0e21e 1396{
2d8e6c8d 1397 STRLEN n_a;
87582a92 1398
3280af22 1399 if (PL_in_eval) {
a0d0e21e 1400 I32 cxix;
a0d0e21e
LW		 1401 I32 gimme;
1402 SV **newsp;
1403
4e6ea2c3 1404 if (message) {
faef0170 1405 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS		 1406 static char prefix[] = "\t(in cleanup) ";
1407 SV *err = ERRSV;
1408 char *e = Nullch;
1409 if (!SvPOK(err))
1410 sv_setpv(err,"");
1411 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1412 e = SvPV(err, n_a);
1413 e += n_a - msglen;
1414 if (*e != *message || strNE(e,message))
1415 e = Nullch;
1416 }
1417 if (!e) {
1418 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1419 sv_catpvn(err, prefix, sizeof(prefix)-1);
1420 sv_catpvn(err, message, msglen);
e476b1b5 1421 if (ckWARN(WARN_MISC)) {
98eae8f5 1422 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
9014280d 1423 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
4e6ea2c3 1424 }
4633a7c4 1425 }
4633a7c4 1426 }
1aa99e6b 1427 else {
06bf62c7 1428 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1429 }
4633a7c4 1430 }
4e6ea2c3 1431
5a844595
GS		 1432 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1433 && PL_curstackinfo->si_prev)
1434 {
bac4b2ad 1435 dounwind(-1);
d3acc0f7 1436 POPSTACK;
bac4b2ad 1437 }
e336de0d 1438
a0d0e21e
LW		 1439 if (cxix >= 0) {
1440 I32 optype;
35a4481c 1441 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1442
1443 if (cxix < cxstack_ix)
1444 dounwind(cxix);
1445
3280af22 1446 POPBLOCK(cx,PL_curpm);
6b35e009 1447 if (CxTYPE(cx) != CXt_EVAL) {
16869676
SG		 1448 if (!message)
1449 message = SvPVx(ERRSV, msglen);
bf49b057
GS		 1450 PerlIO_write(Perl_error_log, "panic: die ", 11);
1451 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1452 my_exit(1);
1453 }
1454 POPEVAL(cx);
1455
1456 if (gimme == G_SCALAR)
3280af22
NIS		 1457 *++newsp = &PL_sv_undef;
1458 PL_stack_sp = newsp;
a0d0e21e
LW		 1459
1460 LEAVE;
748a9306 1461
7fb6a879
GS		 1462 /* LEAVE could clobber PL_curcop (see save_re_context())
1463 * XXX it might be better to find a way to avoid messing with
1464 * PL_curcop in save_re_context() instead, but this is a more
1465 * minimal fix --GSAR */
1466 PL_curcop = cx->blk_oldcop;
1467
7a2e2cd6 1468 if (optype == OP_REQUIRE) {
35a4481c
AL		 1469 const char* msg = SvPVx(ERRSV, n_a);
1470 SV *nsv = cx->blk_eval.old_namesv;
1471 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
27bcc0a7 1472 &PL_sv_undef, 0);
5a844595
GS		 1473 DIE(aTHX_ "%sCompilation failed in require",
1474 *msg ? msg : "Unknown error\n");
7a2e2cd6 1475 }
f39bc417
DM		 1476 assert(CxTYPE(cx) == CXt_EVAL);
1477 return cx->blk_eval.retop;
a0d0e21e
LW		 1478 }
1479 }
9cc2fdd3 1480 if (!message)
06bf62c7 1481 message = SvPVx(ERRSV, msglen);
87582a92 1482
7ff03255 1483 write_to_stderr(message, msglen);
f86702cc 1484 my_failure_exit();
1485 /* NOTREACHED */
a0d0e21e
LW		 1486 return 0;
1487}
1488
1489PP(pp_xor)
1490{
39644a26 1491 dSP; dPOPTOPssrl;
a0d0e21e
LW		 1492 if (SvTRUE(left) != SvTRUE(right))
1493 RETSETYES;
1494 else
1495 RETSETNO;
1496}
1497
1498PP(pp_andassign)
1499{
39644a26 1500 dSP;
a0d0e21e
LW		 1501 if (!SvTRUE(TOPs))
1502 RETURN;
1503 else
1504 RETURNOP(cLOGOP->op_other);
1505}
1506
1507PP(pp_orassign)
1508{
39644a26 1509 dSP;
a0d0e21e
LW		 1510 if (SvTRUE(TOPs))
1511 RETURN;
1512 else
1513 RETURNOP(cLOGOP->op_other);
1514}
c963b151
BD		 1515
1516PP(pp_dorassign)
1517{
1518 dSP;
1519 register SV* sv;
1520
1521 sv = TOPs;
1522 if (!sv || !SvANY(sv)) {
1523 RETURNOP(cLOGOP->op_other);
1524 }
1525
1526 switch (SvTYPE(sv)) {
1527 case SVt_PVAV:
1528 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1529 RETURN;
1530 break;
1531 case SVt_PVHV:
1532 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1533 RETURN;
1534 break;
1535 case SVt_PVCV:
1536 if (CvROOT(sv) || CvXSUB(sv))
1537 RETURN;
1538 break;
1539 default:
1540 if (SvGMAGICAL(sv))
1541 mg_get(sv);
1542 if (SvOK(sv))
1543 RETURN;
1544 }
1545
1546 RETURNOP(cLOGOP->op_other);
1547}
1548
a0d0e21e
LW		 1549PP(pp_caller)
1550{
39644a26 1551 dSP;
a0d0e21e 1552 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1553 register PERL_CONTEXT *cx;
2c375eb9 1554 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1555 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1556 I32 dbcxix;
54310121 1557 I32 gimme;
ed094faf 1558 char *stashname;
a0d0e21e
LW		 1559 SV *sv;
1560 I32 count = 0;
1561
1562 if (MAXARG)
1563 count = POPi;
27d41816 1564
a0d0e21e 1565 for (;;) {
2c375eb9
GS		 1566 /* we may be in a higher stacklevel, so dig down deeper */
1567 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1568 top_si = top_si->si_prev;
1569 ccstack = top_si->si_cxstack;
1570 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1571 }
a0d0e21e 1572 if (cxix < 0) {
27d41816
DM		 1573 if (GIMME != G_ARRAY) {
1574 EXTEND(SP, 1);
a0d0e21e 1575 RETPUSHUNDEF;
27d41816 1576 }
a0d0e21e
LW		 1577 RETURN;
1578 }
3280af22
NIS		 1579 if (PL_DBsub && cxix >= 0 &&
1580 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1581 count++;
1582 if (!count--)
1583 break;
2c375eb9 1584 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1585 }
2c375eb9
GS		 1586
1587 cx = &ccstack[cxix];
7766f137 1588 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2c375eb9
GS		 1589 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1590 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1591 field below is defined for any cx. */
3280af22 1592 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1593 cx = &ccstack[dbcxix];
06a5b730 1594 }
1595
ed094faf 1596 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1597 if (GIMME != G_ARRAY) {
27d41816 1598 EXTEND(SP, 1);
ed094faf 1599 if (!stashname)
3280af22 1600 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1601 else {
1602 dTARGET;
ed094faf 1603 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1604 PUSHs(TARG);
1605 }
a0d0e21e
LW		 1606 RETURN;
1607 }
a0d0e21e 1608
27d41816
DM		 1609 EXTEND(SP, 10);
1610
ed094faf 1611 if (!stashname)
3280af22 1612 PUSHs(&PL_sv_undef);
49d8d3a1 1613 else
ed094faf 1614 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
248c2a4d 1615 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
57843af0 1616 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1617 if (!MAXARG)
1618 RETURN;
7766f137 1619 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
07b8c804 1620 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
7766f137 1621 /* So is ccstack[dbcxix]. */
07b8c804
RGS		 1622 if (isGV(cvgv)) {
1623 sv = NEWSV(49, 0);
1624 gv_efullname3(sv, cvgv, Nullch);
1625 PUSHs(sv_2mortal(sv));
1626 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1627 }
1628 else {
1629 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
72699b0f 1630 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
07b8c804 1631 }
a0d0e21e
LW		 1632 }
1633 else {
79cb57f6 1634 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1635 PUSHs(sv_2mortal(newSViv(0)));
1636 }
54310121 1637 gimme = (I32)cx->blk_gimme;
1638 if (gimme == G_VOID)
3280af22 1639 PUSHs(&PL_sv_undef);
54310121 1640 else
1641 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1642 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1643 /* eval STRING */
06a5b730 1644 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1645 PUSHs(cx->blk_eval.cur_text);
3280af22 1646 PUSHs(&PL_sv_no);
0f79a09d 1647 }
811a4de9 1648 /* require */
0f79a09d
GS		 1649 else if (cx->blk_eval.old_namesv) {
1650 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1651 PUSHs(&PL_sv_yes);
06a5b730 1652 }
811a4de9
GS		 1653 /* eval BLOCK (try blocks have old_namesv == 0) */
1654 else {
1655 PUSHs(&PL_sv_undef);
1656 PUSHs(&PL_sv_undef);
1657 }
4633a7c4 1658 }
a682de96
GS		 1659 else {
1660 PUSHs(&PL_sv_undef);
1661 PUSHs(&PL_sv_undef);
1662 }
1663 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1664 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1665 {
a0d0e21e
LW		 1666 AV *ary = cx->blk_sub.argarray;
1667 int off = AvARRAY(ary) - AvALLOC(ary);
1668
3280af22 1669 if (!PL_dbargs) {
a0d0e21e 1670 GV* tmpgv;
3280af22 1671 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1672 SVt_PVAV)));
a5f75d66 1673 GvMULTI_on(tmpgv);
3ddcf04c 1674 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
a0d0e21e
LW		 1675 }
1676
3280af22
NIS		 1677 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1678 av_extend(PL_dbargs, AvFILLp(ary) + off);
1679 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1680 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1681 }
f3aa04c2
GS		 1682 /* XXX only hints propagated via op_private are currently
1683 * visible (others are not easily accessible, since they
1684 * use the global PL_hints) */
1685 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1686 HINT_PRIVATE_MASK)));
e476b1b5
GS		 1687 {
1688 SV * mask ;
1689 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba 1690
ac27b0f5 1691 if (old_warnings == pWARN_NONE ||
114bafba 1692 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1693 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
ac27b0f5 1694 else if (old_warnings == pWARN_ALL ||
75b6c4ca
RGS		 1695 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1696 /* Get the bit mask for $warnings::Bits{all}, because
1697 * it could have been extended by warnings::register */
1698 SV **bits_all;
1699 HV *bits = get_hv("warnings::Bits", FALSE);
1700 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1701 mask = newSVsv(*bits_all);
1702 }
1703 else {
1704 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1705 }
1706 }
e476b1b5
GS		 1707 else
1708 mask = newSVsv(old_warnings);
1709 PUSHs(sv_2mortal(mask));
1710 }
a0d0e21e
LW		 1711 RETURN;
1712}
1713
a0d0e21e
LW		 1714PP(pp_reset)
1715{
39644a26 1716 dSP;
a0d0e21e 1717 char *tmps;
2d8e6c8d 1718 STRLEN n_a;
a0d0e21e
LW		 1719
1720 if (MAXARG < 1)
1721 tmps = "";
1722 else
2d8e6c8d 1723 tmps = POPpx;
11faa288 1724 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1725 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1726 RETURN;
1727}
1728
1729PP(pp_lineseq)
1730{
1731 return NORMAL;
1732}
1733
dd2155a4
DM		 1734/* like pp_nextstate, but used instead when the debugger is active */
1735
a0d0e21e
LW		 1736PP(pp_dbstate)
1737{
533c011a 1738 PL_curcop = (COP*)PL_op;
a0d0e21e 1739 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1740 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1741 FREETMPS;
1742
5df8de69
DM		 1743 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1744 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1745 {
39644a26 1746 dSP;
a0d0e21e 1747 register CV *cv;
c09156bb 1748 register PERL_CONTEXT *cx;
748a9306 1749 I32 gimme = G_ARRAY;
eb160463 1750 U8 hasargs;
a0d0e21e
LW		 1751 GV *gv;
1752
3280af22 1753 gv = PL_DBgv;
a0d0e21e 1754 cv = GvCV(gv);
a0d0e21e 1755 if (!cv)
cea2e8a9 1756 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1757
aea4f609
DM		 1758 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1759 /* don't do recursive DB::DB call */
a0d0e21e 1760 return NORMAL;
748a9306 1761
4633a7c4
LW		 1762 ENTER;
1763 SAVETMPS;
1764
3280af22 1765 SAVEI32(PL_debug);
55497cff 1766 SAVESTACK_POS();
3280af22 1767 PL_debug = 0;
748a9306 1768 hasargs = 0;
924508f0 1769 SPAGAIN;
748a9306 1770
924508f0 1771 PUSHBLOCK(cx, CXt_SUB, SP);
ee98a1d6 1772 PUSHSUB_DB(cx);
f39bc417 1773 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 1774 CvDEPTH(cv)++;
dd2155a4 1775 PAD_SET_CUR(CvPADLIST(cv),1);
a0d0e21e
LW		 1776 RETURNOP(CvSTART(cv));
1777 }
1778 else
1779 return NORMAL;
1780}
1781
1782PP(pp_scope)
1783{
1784 return NORMAL;
1785}
1786
1787PP(pp_enteriter)
1788{
39644a26 1789 dSP; dMARK;
c09156bb 1790 register PERL_CONTEXT *cx;
54310121 1791 I32 gimme = GIMME_V;
a0d0e21e 1792 SV **svp;
7766f137
GS		 1793 U32 cxtype = CXt_LOOP;
1794#ifdef USE_ITHREADS
1795 void *iterdata;
1796#endif
a0d0e21e 1797
4633a7c4
LW		 1798 ENTER;
1799 SAVETMPS;
1800
533c011a 1801 if (PL_op->op_targ) {
14f338dc
DM		 1802 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1803 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1804 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1805 SVs_PADSTALE, SVs_PADSTALE);
1806 }
c3564e5c 1807#ifndef USE_ITHREADS
dd2155a4 1808 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1809 SAVESPTR(*svp);
c3564e5c
GS		 1810#else
1811 SAVEPADSV(PL_op->op_targ);
cbfa9890 1812 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1813 cxtype |= CXp_PADVAR;
1814#endif
54b9620d
MB		 1815 }
1816 else {
7766f137
GS		 1817 GV *gv = (GV*)POPs;
1818 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1819 SAVEGENERICSV(*svp);
1820 *svp = NEWSV(0,0);
7766f137
GS		 1821#ifdef USE_ITHREADS
1822 iterdata = (void*)gv;
1823#endif
54b9620d 1824 }
4633a7c4 1825
a0d0e21e
LW		 1826 ENTER;
1827
7766f137
GS		 1828 PUSHBLOCK(cx, cxtype, SP);
1829#ifdef USE_ITHREADS
1830 PUSHLOOP(cx, iterdata, MARK);
1831#else
a0d0e21e 1832 PUSHLOOP(cx, svp, MARK);
7766f137 1833#endif
533c011a 1834 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1835 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1836 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1837 dPOPss;
4fe3f0fa
MHM		 1838 SV *right = (SV*)cx->blk_loop.iterary;
1839 if (RANGE_IS_NUMERIC(sv,right)) {
1840 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1841 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1842 DIE(aTHX_ "Range iterator outside integer range");
1843 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1844 cx->blk_loop.itermax = SvIV(right);
89ea2908 1845 }
3f63a782
MHM		 1846 else {
1847 STRLEN n_a;
89ea2908 1848 cx->blk_loop.iterlval = newSVsv(sv);
4fe3f0fa
MHM		 1849 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1850 (void) SvPV(right,n_a);
3f63a782 1851 }
89ea2908 1852 }
ef3e5ea9 1853 else if (PL_op->op_private & OPpITER_REVERSED) {
e682d7b7 1854 cx->blk_loop.itermax = -1;
ef3e5ea9
NC		 1855 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1856
1857 }
89ea2908 1858 }
4633a7c4 1859 else {
3280af22
NIS		 1860 cx->blk_loop.iterary = PL_curstack;
1861 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9
NC		 1862 if (PL_op->op_private & OPpITER_REVERSED) {
1863 cx->blk_loop.itermax = MARK - PL_stack_base;
1864 cx->blk_loop.iterix = cx->blk_oldsp;
1865 }
1866 else {
1867 cx->blk_loop.iterix = MARK - PL_stack_base;
1868 }
4633a7c4 1869 }
a0d0e21e
LW		 1870
1871 RETURN;
1872}
1873
1874PP(pp_enterloop)
1875{
39644a26 1876 dSP;
c09156bb 1877 register PERL_CONTEXT *cx;
54310121 1878 I32 gimme = GIMME_V;
a0d0e21e
LW		 1879
1880 ENTER;
1881 SAVETMPS;
1882 ENTER;
1883
1884 PUSHBLOCK(cx, CXt_LOOP, SP);
1885 PUSHLOOP(cx, 0, SP);
1886
1887 RETURN;
1888}
1889
1890PP(pp_leaveloop)
1891{
39644a26 1892 dSP;
c09156bb 1893 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1894 I32 gimme;
1895 SV **newsp;
1896 PMOP *newpm;
1897 SV **mark;
1898
1899 POPBLOCK(cx,newpm);
4fdae800 1900 mark = newsp;
a8bba7fa 1901 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1902
a1f49e72 1903 TAINT_NOT;
54310121 1904 if (gimme == G_VOID)
1905 ; /* do nothing */
1906 else if (gimme == G_SCALAR) {
1907 if (mark < SP)
1908 *++newsp = sv_mortalcopy(*SP);
1909 else
3280af22 1910 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1911 }
1912 else {
a1f49e72 1913 while (mark < SP) {
a0d0e21e 1914 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1915 TAINT_NOT; /* Each item is independent */
1916 }
a0d0e21e 1917 }
f86702cc 1918 SP = newsp;
1919 PUTBACK;
1920
a8bba7fa 1921 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1922 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1923
a0d0e21e
LW		 1924 LEAVE;
1925 LEAVE;
1926
f86702cc 1927 return NORMAL;
a0d0e21e
LW		 1928}
1929
1930PP(pp_return)
1931{
39644a26 1932 dSP; dMARK;
a0d0e21e 1933 I32 cxix;
c09156bb 1934 register PERL_CONTEXT *cx;
f86702cc 1935 bool popsub2 = FALSE;
b45de488 1936 bool clear_errsv = FALSE;
a0d0e21e
LW		 1937 I32 gimme;
1938 SV **newsp;
1939 PMOP *newpm;
1940 I32 optype = 0;
b0d9ce38 1941 SV *sv;
f39bc417 1942 OP *retop;
a0d0e21e 1943
3280af22 1944 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS		 1945 if (cxstack_ix == PL_sortcxix
1946 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1947 {
3280af22
NIS		 1948 if (cxstack_ix > PL_sortcxix)
1949 dounwind(PL_sortcxix);
1950 AvARRAY(PL_curstack)[1] = *SP;
1951 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1952 return 0;
1953 }
1954 }
1955
1956 cxix = dopoptosub(cxstack_ix);
1957 if (cxix < 0)
cea2e8a9 1958 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1959 if (cxix < cxstack_ix)
1960 dounwind(cxix);
1961
1962 POPBLOCK(cx,newpm);
6b35e009 1963 switch (CxTYPE(cx)) {
a0d0e21e 1964 case CXt_SUB:
f86702cc 1965 popsub2 = TRUE;
f39bc417 1966 retop = cx->blk_sub.retop;
5dd42e15 1967 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 1968 break;
1969 case CXt_EVAL:
b45de488
GS		 1970 if (!(PL_in_eval & EVAL_KEEPERR))
1971 clear_errsv = TRUE;
a0d0e21e 1972 POPEVAL(cx);
f39bc417 1973 retop = cx->blk_eval.retop;
1d76a5c3
GS		 1974 if (CxTRYBLOCK(cx))
1975 break;
067f92a0 1976 lex_end();
748a9306
LW		 1977 if (optype == OP_REQUIRE &&
1978 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1979 {
54310121 1980 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 1981 SV *nsv = cx->blk_eval.old_namesv;
1982 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1983 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1984 }
a0d0e21e 1985 break;
7766f137
GS		 1986 case CXt_FORMAT:
1987 POPFORMAT(cx);
f39bc417 1988 retop = cx->blk_sub.retop;
7766f137 1989 break;
a0d0e21e 1990 default:
cea2e8a9 1991 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1992 }
1993
a1f49e72 1994 TAINT_NOT;
a0d0e21e 1995 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1996 if (MARK < SP) {
1997 if (popsub2) {
a8bba7fa 1998 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 1999 if (SvTEMP(TOPs)) {
2000 *++newsp = SvREFCNT_inc(*SP);
2001 FREETMPS;
2002 sv_2mortal(*newsp);
959e3673
GS		 2003 }
2004 else {
2005 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 2006 FREETMPS;
959e3673
GS		 2007 *++newsp = sv_mortalcopy(sv);
2008 SvREFCNT_dec(sv);
a29cdaf0 2009 }
959e3673
GS		 2010 }
2011 else
a29cdaf0 2012 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2013 }
2014 else
a29cdaf0 2015 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2016 }
2017 else
3280af22 2018 *++newsp = &PL_sv_undef;
a0d0e21e 2019 }
54310121 2020 else if (gimme == G_ARRAY) {
a1f49e72 2021 while (++MARK <= SP) {
f86702cc 2022 *++newsp = (popsub2 && SvTEMP(*MARK))
2023 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2024 TAINT_NOT; /* Each item is independent */
2025 }
a0d0e21e 2026 }
3280af22 2027 PL_stack_sp = newsp;
a0d0e21e 2028
5dd42e15 2029 LEAVE;
f86702cc 2030 /* Stack values are safe: */
2031 if (popsub2) {
5dd42e15 2032 cxstack_ix--;
b0d9ce38 2033 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2034 }
b0d9ce38
GS		 2035 else
2036 sv = Nullsv;
3280af22 2037 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2038
b0d9ce38 2039 LEAVESUB(sv);
b45de488
GS		 2040 if (clear_errsv)
2041 sv_setpv(ERRSV,"");
f39bc417 2042 return retop;
a0d0e21e
LW		 2043}
2044
2045PP(pp_last)
2046{
39644a26 2047 dSP;
a0d0e21e 2048 I32 cxix;
c09156bb 2049 register PERL_CONTEXT *cx;
f86702cc 2050 I32 pop2 = 0;
a0d0e21e
LW		 2051 I32 gimme;
2052 I32 optype;
2053 OP *nextop;
2054 SV **newsp;
2055 PMOP *newpm;
a8bba7fa 2056 SV **mark;
b0d9ce38 2057 SV *sv = Nullsv;
a0d0e21e 2058
533c011a 2059 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2060 cxix = dopoptoloop(cxstack_ix);
2061 if (cxix < 0)
a651a37d 2062 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2063 }
2064 else {
2065 cxix = dopoptolabel(cPVOP->op_pv);
2066 if (cxix < 0)
cea2e8a9 2067 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2068 }
2069 if (cxix < cxstack_ix)
2070 dounwind(cxix);
2071
2072 POPBLOCK(cx,newpm);
5dd42e15 2073 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2074 mark = newsp;
6b35e009 2075 switch (CxTYPE(cx)) {
a0d0e21e 2076 case CXt_LOOP:
f86702cc 2077 pop2 = CXt_LOOP;
a8bba7fa
GS		 2078 newsp = PL_stack_base + cx->blk_loop.resetsp;
2079 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2080 break;
f86702cc 2081 case CXt_SUB:
f86702cc 2082 pop2 = CXt_SUB;
f39bc417 2083 nextop = cx->blk_sub.retop;
a0d0e21e 2084 break;
f86702cc 2085 case CXt_EVAL:
2086 POPEVAL(cx);
f39bc417 2087 nextop = cx->blk_eval.retop;
a0d0e21e 2088 break;
7766f137
GS		 2089 case CXt_FORMAT:
2090 POPFORMAT(cx);
f39bc417 2091 nextop = cx->blk_sub.retop;
7766f137 2092 break;
a0d0e21e 2093 default:
cea2e8a9 2094 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2095 }
2096
a1f49e72 2097 TAINT_NOT;
a0d0e21e 2098 if (gimme == G_SCALAR) {
f86702cc 2099 if (MARK < SP)
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2101 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2102 else
3280af22 2103 *++newsp = &PL_sv_undef;
a0d0e21e 2104 }
54310121 2105 else if (gimme == G_ARRAY) {
a1f49e72 2106 while (++MARK <= SP) {
f86702cc 2107 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2108 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2109 TAINT_NOT; /* Each item is independent */
2110 }
f86702cc 2111 }
2112 SP = newsp;
2113 PUTBACK;
2114
5dd42e15
DM		 2115 LEAVE;
2116 cxstack_ix--;
f86702cc 2117 /* Stack values are safe: */
2118 switch (pop2) {
2119 case CXt_LOOP:
a8bba7fa 2120 POPLOOP(cx); /* release loop vars ... */
4fdae800 2121 LEAVE;
f86702cc 2122 break;
2123 case CXt_SUB:
b0d9ce38 2124 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2125 break;
a0d0e21e 2126 }
3280af22 2127 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2128
b0d9ce38 2129 LEAVESUB(sv);
f86702cc 2130 return nextop;
a0d0e21e
LW		 2131}
2132
2133PP(pp_next)
2134{
2135 I32 cxix;
c09156bb 2136 register PERL_CONTEXT *cx;
85538317 2137 I32 inner;
a0d0e21e 2138
533c011a 2139 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2140 cxix = dopoptoloop(cxstack_ix);
2141 if (cxix < 0)
a651a37d 2142 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2143 }
2144 else {
2145 cxix = dopoptolabel(cPVOP->op_pv);
2146 if (cxix < 0)
cea2e8a9 2147 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2148 }
2149 if (cxix < cxstack_ix)
2150 dounwind(cxix);
2151
85538317
GS		 2152 /* clear off anything above the scope we're re-entering, but
2153 * save the rest until after a possible continue block */
2154 inner = PL_scopestack_ix;
1ba6ee2b 2155 TOPBLOCK(cx);
85538317
GS		 2156 if (PL_scopestack_ix < inner)
2157 leave_scope(PL_scopestack[PL_scopestack_ix]);
1ba6ee2b 2158 return cx->blk_loop.next_op;
a0d0e21e
LW		 2159}
2160
2161PP(pp_redo)
2162{
2163 I32 cxix;
c09156bb 2164 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2165 I32 oldsave;
2166
533c011a 2167 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2168 cxix = dopoptoloop(cxstack_ix);
2169 if (cxix < 0)
a651a37d 2170 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2171 }
2172 else {
2173 cxix = dopoptolabel(cPVOP->op_pv);
2174 if (cxix < 0)
cea2e8a9 2175 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2176 }
2177 if (cxix < cxstack_ix)
2178 dounwind(cxix);
2179
2180 TOPBLOCK(cx);
3280af22 2181 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2182 LEAVE_SCOPE(oldsave);
936c78b5 2183 FREETMPS;
a0d0e21e
LW		 2184 return cx->blk_loop.redo_op;
2185}
2186
0824fdcb 2187STATIC OP *
cea2e8a9 2188S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e 2189{
4ea42e7f 2190 OP *kid = Nullop;
a0d0e21e 2191 OP **ops = opstack;
fc36a67e 2192 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2193
fc36a67e 2194 if (ops >= oplimit)
cea2e8a9 2195 Perl_croak(aTHX_ too_deep);
11343788
MB		 2196 if (o->op_type == OP_LEAVE ||
2197 o->op_type == OP_SCOPE ||
2198 o->op_type == OP_LEAVELOOP ||
33d34e4c 2199 o->op_type == OP_LEAVESUB ||
11343788 2200 o->op_type == OP_LEAVETRY)
fc36a67e 2201 {
5dc0d613 2202 *ops++ = cUNOPo->op_first;
fc36a67e 2203 if (ops >= oplimit)
cea2e8a9 2204 Perl_croak(aTHX_ too_deep);
fc36a67e 2205 }
c4aa4e48 2206 *ops = 0;
11343788 2207 if (o->op_flags & OPf_KIDS) {
a0d0e21e 2208 /* First try all the kids at this level, since that's likeliest. */
11343788 2209 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2210 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2211 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2212 return kid;
2213 }
11343788 2214 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2215 if (kid == PL_lastgotoprobe)
a0d0e21e 2216 continue;
ed8d0fe2
SM		 2217 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2218 if (ops == opstack)
2219 *ops++ = kid;
2220 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2221 ops[-1]->op_type == OP_DBSTATE)
2222 ops[-1] = kid;
2223 else
2224 *ops++ = kid;
2225 }
155aba94 2226 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2227 return o;
a0d0e21e
LW		 2228 }
2229 }
c4aa4e48 2230 *ops = 0;
a0d0e21e
LW		 2231 return 0;
2232}
2233
2234PP(pp_dump)
2235{
cea2e8a9 2236 return pp_goto();
a0d0e21e
LW		 2237 /*NOTREACHED*/
2238}
2239
2240PP(pp_goto)
2241{
39644a26 2242 dSP;
a0d0e21e
LW		 2243 OP *retop = 0;
2244 I32 ix;
c09156bb 2245 register PERL_CONTEXT *cx;
fc36a67e 2246#define GOTO_DEPTH 64
2247 OP *enterops[GOTO_DEPTH];
a0d0e21e 2248 char *label;
533c011a 2249 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2250 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 2251
2252 label = 0;
533c011a 2253 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2254 SV *sv = POPs;
2d8e6c8d 2255 STRLEN n_a;
a0d0e21e
LW		 2256
2257 /* This egregious kludge implements goto &subroutine */
2258 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2259 I32 cxix;
c09156bb 2260 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2261 CV* cv = (CV*)SvRV(sv);
2262 SV** mark;
2263 I32 items = 0;
2264 I32 oldsave;
b1464ded 2265 bool reified = 0;
a0d0e21e 2266
e8f7dd13 2267 retry:
4aa0a1f7 2268 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2269 const GV * const gv = CvGV(cv);
e8f7dd13 2270 if (gv) {
7fc63493 2271 GV *autogv;
e8f7dd13
GS		 2272 SV *tmpstr;
2273 /* autoloaded stub? */
2274 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2275 goto retry;
2276 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2277 GvNAMELEN(gv), FALSE);
2278 if (autogv && (cv = GvCV(autogv)))
2279 goto retry;
2280 tmpstr = sv_newmortal();
2281 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2282 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2283 }
cea2e8a9 2284 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2285 }
2286
a0d0e21e 2287 /* First do some returnish stuff. */
7fc63493 2288 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2289 FREETMPS;
a0d0e21e
LW		 2290 cxix = dopoptosub(cxstack_ix);
2291 if (cxix < 0)
cea2e8a9 2292 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2293 if (cxix < cxstack_ix)
2294 dounwind(cxix);
2295 TOPBLOCK(cx);
63b28e3f 2296 if (CxREALEVAL(cx))
cea2e8a9 2297 DIE(aTHX_ "Can't goto subroutine from an eval-string");
d8b46c1b
GS		 2298 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2299 /* put @_ back onto stack */
a0d0e21e
LW		 2300 AV* av = cx->blk_sub.argarray;
2301
93965878 2302 items = AvFILLp(av) + 1;
a45cdc79
DM		 2303 EXTEND(SP, items+1); /* @_ could have been extended. */
2304 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2305 SvREFCNT_dec(GvAV(PL_defgv));
2306 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2307 CLEAR_ARGARRAY(av);
d8b46c1b 2308 /* abandon @_ if it got reified */
62b1ebc2 2309 if (AvREAL(av)) {
b1464ded
DM		 2310 reified = 1;
2311 SvREFCNT_dec(av);
d8b46c1b
GS		 2312 av = newAV();
2313 av_extend(av, items-1);
2314 AvFLAGS(av) = AVf_REIFY;
dd2155a4 2315 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2316 }
a0d0e21e 2317 }
1fa4e549
AD		 2318 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2319 AV* av;
3280af22 2320 av = GvAV(PL_defgv);
1fa4e549 2321 items = AvFILLp(av) + 1;
a45cdc79
DM		 2322 EXTEND(SP, items+1); /* @_ could have been extended. */
2323 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2324 }
a45cdc79
DM		 2325 mark = SP;
2326 SP += items;
6b35e009 2327 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2328 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2329 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2330 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2331 LEAVE_SCOPE(oldsave);
2332
2333 /* Now do some callish stuff. */
2334 SAVETMPS;
5023d17a 2335 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2336 if (CvXSUB(cv)) {
b1464ded
DM		 2337 if (reified) {
2338 I32 index;
2339 for (index=0; index<items; index++)
2340 sv_2mortal(SP[-index]);
2341 }
67caa1fe 2342#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2343 if (CvOLDSTYLE(cv)) {
20ce7b12 2344 I32 (*fp3)(int,int,int);
924508f0
GS		 2345 while (SP > mark) {
2346 SP[1] = SP[0];
2347 SP--;
a0d0e21e 2348 }
7766f137 2349 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2350 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2351 mark - PL_stack_base + 1,
ecfc5424 2352 items);
3280af22 2353 SP = PL_stack_base + items;
a0d0e21e 2354 }
67caa1fe
GS		 2355 else
2356#endif /* PERL_XSUB_OLDSTYLE */
2357 {
1fa4e549
AD		 2358 SV **newsp;
2359 I32 gimme;
2360
1fa4e549 2361 /* Push a mark for the start of arglist */
ac27b0f5 2362 PUSHMARK(mark);
a45cdc79 2363 PUTBACK;
acfe0abc 2364 (void)(*CvXSUB(cv))(aTHX_ cv);
1fa4e549 2365 /* Pop the current context like a decent sub should */
3280af22 2366 POPBLOCK(cx, PL_curpm);
1fa4e549 2367 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2368 }
2369 LEAVE;
f39bc417
DM		 2370 assert(CxTYPE(cx) == CXt_SUB);
2371 return cx->blk_sub.retop;
a0d0e21e
LW		 2372 }
2373 else {
2374 AV* padlist = CvPADLIST(cv);
6b35e009 2375 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2376 PL_in_eval = cx->blk_eval.old_in_eval;
2377 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2378 cx->cx_type = CXt_SUB;
2379 cx->blk_sub.hasargs = 0;
2380 }
a0d0e21e 2381 cx->blk_sub.cv = cv;
eb160463 2382 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2383
a0d0e21e
LW		 2384 CvDEPTH(cv)++;
2385 if (CvDEPTH(cv) < 2)
2386 (void)SvREFCNT_inc(cv);
dd2155a4 2387 else {
599cee73 2388 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2389 sub_crush_depth(cv);
26019298 2390 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2391 }
dd2155a4 2392 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2393 if (cx->blk_sub.hasargs)
6d4ff0d2 2394 {
dd2155a4 2395 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2396 SV** ary;
2397
3280af22
NIS		 2398 cx->blk_sub.savearray = GvAV(PL_defgv);
2399 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2400 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2401 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2402
2403 if (items >= AvMAX(av) + 1) {
2404 ary = AvALLOC(av);
2405 if (AvARRAY(av) != ary) {
2406 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407 SvPVX(av) = (char*)ary;
2408 }
2409 if (items >= AvMAX(av) + 1) {
2410 AvMAX(av) = items - 1;
2411 Renew(ary,items+1,SV*);
2412 AvALLOC(av) = ary;
2413 SvPVX(av) = (char*)ary;
2414 }
2415 }
a45cdc79 2416 ++mark;
a0d0e21e 2417 Copy(mark,AvARRAY(av),items,SV*);
93965878 2418 AvFILLp(av) = items - 1;
d8b46c1b 2419 assert(!AvREAL(av));
b1464ded
DM		 2420 if (reified) {
2421 /* transfer 'ownership' of refcnts to new @_ */
2422 AvREAL_on(av);
2423 AvREIFY_off(av);
2424 }
a0d0e21e
LW		 2425 while (items--) {
2426 if (*mark)
2427 SvTEMP_off(*mark);
2428 mark++;
2429 }
2430 }
491527d0 2431 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2432 /*
2433 * We do not care about using sv to call CV;
2434 * it's for informational purposes only.
2435 */
3280af22 2436 SV *sv = GvSV(PL_DBsub);
491527d0 2437 CV *gotocv;
ac27b0f5 2438
491527d0 2439 if (PERLDB_SUB_NN) {
7619c85e
RG		 2440 (void)SvUPGRADE(sv, SVt_PVIV);
2441 (void)SvIOK_on(sv);
2442 SAVEIV(SvIVX(sv));
2443 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
491527d0
GS		 2444 } else {
2445 save_item(sv);
2446 gv_efullname3(sv, CvGV(cv), Nullch);
2447 }
2448 if ( PERLDB_GOTO
864dbfa3 2449 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2450 PUSHMARK( PL_stack_sp );
864dbfa3 2451 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2452 PL_stack_sp--;
491527d0 2453 }
1ce6579f 2454 }
a0d0e21e
LW		 2455 RETURNOP(CvSTART(cv));
2456 }
2457 }
1614b0e3 2458 else {
2d8e6c8d 2459 label = SvPV(sv,n_a);
1614b0e3 2460 if (!(do_dump || *label))
cea2e8a9 2461 DIE(aTHX_ must_have_label);
1614b0e3 2462 }
a0d0e21e 2463 }
533c011a 2464 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2465 if (! do_dump)
cea2e8a9 2466 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2467 }
2468 else
2469 label = cPVOP->op_pv;
2470
2471 if (label && *label) {
2472 OP *gotoprobe = 0;
3b2447bc 2473 bool leaving_eval = FALSE;
33d34e4c 2474 bool in_block = FALSE;
a4f3a277 2475 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2476
2477 /* find label */
2478
3280af22 2479 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2480 *enterops = 0;
2481 for (ix = cxstack_ix; ix >= 0; ix--) {
2482 cx = &cxstack[ix];
6b35e009 2483 switch (CxTYPE(cx)) {
a0d0e21e 2484 case CXt_EVAL:
3b2447bc 2485 leaving_eval = TRUE;
971ecbe6 2486 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2487 gotoprobe = (last_eval_cx ?
2488 last_eval_cx->blk_eval.old_eval_root :
2489 PL_eval_root);
2490 last_eval_cx = cx;
9c5794fe
RH		 2491 break;
2492 }
2493 /* else fall through */
a0d0e21e
LW		 2494 case CXt_LOOP:
2495 gotoprobe = cx->blk_oldcop->op_sibling;
2496 break;
2497 case CXt_SUBST:
2498 continue;
2499 case CXt_BLOCK:
33d34e4c 2500 if (ix) {
a0d0e21e 2501 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2502 in_block = TRUE;
2503 } else
3280af22 2504 gotoprobe = PL_main_root;
a0d0e21e 2505 break;
b3933176
CS		 2506 case CXt_SUB:
2507 if (CvDEPTH(cx->blk_sub.cv)) {
2508 gotoprobe = CvROOT(cx->blk_sub.cv);
2509 break;
2510 }
2511 /* FALL THROUGH */
7766f137 2512 case CXt_FORMAT:
0a753a76 2513 case CXt_NULL:
a651a37d 2514 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2515 default:
2516 if (ix)
cea2e8a9 2517 DIE(aTHX_ "panic: goto");
3280af22 2518 gotoprobe = PL_main_root;
a0d0e21e
LW		 2519 break;
2520 }
2b597662
GS		 2521 if (gotoprobe) {
2522 retop = dofindlabel(gotoprobe, label,
2523 enterops, enterops + GOTO_DEPTH);
2524 if (retop)
2525 break;
2526 }
3280af22 2527 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2528 }
2529 if (!retop)
cea2e8a9 2530 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2531
3b2447bc
RH		 2532 /* if we're leaving an eval, check before we pop any frames
2533 that we're not going to punt, otherwise the error
2534 won't be caught */
2535
2536 if (leaving_eval && *enterops && enterops[1]) {
2537 I32 i;
2538 for (i = 1; enterops[i]; i++)
2539 if (enterops[i]->op_type == OP_ENTERITER)
2540 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2541 }
2542
a0d0e21e
LW		 2543 /* pop unwanted frames */
2544
2545 if (ix < cxstack_ix) {
2546 I32 oldsave;
2547
2548 if (ix < 0)
2549 ix = 0;
2550 dounwind(ix);
2551 TOPBLOCK(cx);
3280af22 2552 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2553 LEAVE_SCOPE(oldsave);
2554 }
2555
2556 /* push wanted frames */
2557
748a9306 2558 if (*enterops && enterops[1]) {
533c011a 2559 OP *oldop = PL_op;
33d34e4c
AE		 2560 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2561 for (; enterops[ix]; ix++) {
533c011a 2562 PL_op = enterops[ix];
84902520
TB		 2563 /* Eventually we may want to stack the needed arguments
2564 * for each op. For now, we punt on the hard ones. */
533c011a 2565 if (PL_op->op_type == OP_ENTERITER)
894356b3 2566 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2567 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2568 }
533c011a 2569 PL_op = oldop;
a0d0e21e
LW		 2570 }
2571 }
2572
2573 if (do_dump) {
a5f75d66 2574#ifdef VMS
6b88bc9c 2575 if (!retop) retop = PL_main_start;
a5f75d66 2576#endif
3280af22
NIS		 2577 PL_restartop = retop;
2578 PL_do_undump = TRUE;
a0d0e21e
LW		 2579
2580 my_unexec();
2581
3280af22
NIS		 2582 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2583 PL_do_undump = FALSE;
a0d0e21e
LW		 2584 }
2585
2586 RETURNOP(retop);
2587}
2588
2589PP(pp_exit)
2590{
39644a26 2591 dSP;
a0d0e21e
LW		 2592 I32 anum;
2593
2594 if (MAXARG < 1)
2595 anum = 0;
ff0cee69 2596 else {
a0d0e21e 2597 anum = SvIVx(POPs);
d98f61e7
GS		 2598#ifdef VMS
2599 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2600 anum = 0;
96e176bf 2601 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2602#endif
2603 }
cc3604b1 2604 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2605 my_exit(anum);
3280af22 2606 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2607 RETURN;
2608}
2609
2610#ifdef NOTYET
2611PP(pp_nswitch)
2612{
39644a26 2613 dSP;
65202027 2614 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2615 register I32 match = I_32(value);
2616
2617 if (value < 0.0) {
65202027 2618 if (((NV)match) > value)
a0d0e21e
LW		 2619 --match; /* was fractional--truncate other way */
2620 }
2621 match -= cCOP->uop.scop.scop_offset;
2622 if (match < 0)
2623 match = 0;
2624 else if (match > cCOP->uop.scop.scop_max)
2625 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2626 PL_op = cCOP->uop.scop.scop_next[match];
2627 RETURNOP(PL_op);
a0d0e21e
LW		 2628}
2629
2630PP(pp_cswitch)
2631{
39644a26 2632 dSP;
a0d0e21e
LW		 2633 register I32 match;
2634
6b88bc9c
GS		 2635 if (PL_multiline)
2636 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2637 else {
2d8e6c8d
GS		 2638 STRLEN n_a;
2639 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2640 match -= cCOP->uop.scop.scop_offset;
2641 if (match < 0)
2642 match = 0;
2643 else if (match > cCOP->uop.scop.scop_max)
2644 match = cCOP->uop.scop.scop_max;
6b88bc9c 2645 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2646 }
6b88bc9c 2647 RETURNOP(PL_op);
a0d0e21e
LW		 2648}
2649#endif
2650
2651/* Eval. */
2652
0824fdcb 2653STATIC void
cea2e8a9 2654S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2655{
2656 register char *s = SvPVX(sv);
2657 register char *send = SvPVX(sv) + SvCUR(sv);
2658 register char *t;
2659 register I32 line = 1;
2660
2661 while (s && s < send) {
2662 SV *tmpstr = NEWSV(85,0);
2663
2664 sv_upgrade(tmpstr, SVt_PVMG);
2665 t = strchr(s, '\n');
2666 if (t)
2667 t++;
2668 else
2669 t = send;
2670
2671 sv_setpvn(tmpstr, s, t - s);
2672 av_store(array, line++, tmpstr);
2673 s = t;
2674 }
2675}
2676
14dd3ad8
GS		 2677STATIC void *
2678S_docatch_body(pTHX)
2679{
cea2e8a9 2680 CALLRUNOPS(aTHX);
312caa8e
CS		 2681 return NULL;
2682}
2683
0824fdcb 2684STATIC OP *
cea2e8a9 2685S_docatch(pTHX_ OP *o)
1e422769 2686{
6224f72b 2687 int ret;
533c011a 2688 OP *oldop = PL_op;
8bffa5f8 2689 OP *retop;
0cdb2077 2690 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2691 dJMPENV;
1e422769 2692
1e422769 2693#ifdef DEBUGGING
54310121 2694 assert(CATCH_GET == TRUE);
1e422769 2695#endif
312caa8e 2696 PL_op = o;
8bffa5f8
DM		 2697
2698 /* Normally, the leavetry at the end of this block of ops will
2699 * pop an op off the return stack and continue there. By setting
2700 * the op to Nullop, we force an exit from the inner runops()
2701 * loop. DAPM.
2702 */
f39bc417
DM		 2703 assert(cxstack_ix >= 0);
2704 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2705 retop = cxstack[cxstack_ix].blk_eval.retop;
2706 cxstack[cxstack_ix].blk_eval.retop = Nullop;
8bffa5f8 2707
14dd3ad8 2708 JMPENV_PUSH(ret);
6224f72b 2709 switch (ret) {
312caa8e 2710 case 0:
14dd3ad8
GS		 2711 redo_body:
2712 docatch_body();
312caa8e
CS		 2713 break;
2714 case 3:
8bffa5f8 2715 /* die caught by an inner eval - continue inner loop */
0cdb2077 2716 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2717 PL_op = PL_restartop;
2718 PL_restartop = 0;
2719 goto redo_body;
2720 }
8bffa5f8
DM		 2721 /* a die in this eval - continue in outer loop */
2722 if (!PL_restartop)
2723 break;
312caa8e
CS		 2724 /* FALL THROUGH */
2725 default:
14dd3ad8 2726 JMPENV_POP;
533c011a 2727 PL_op = oldop;
6224f72b 2728 JMPENV_JUMP(ret);
1e422769 2729 /* NOTREACHED */
1e422769 2730 }
14dd3ad8 2731 JMPENV_POP;
533c011a 2732 PL_op = oldop;
8bffa5f8 2733 return retop;
1e422769 2734}
2735
c277df42 2736OP *
f3548bdc 2737Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
c277df42
IZ		 2738/* sv Text to convert to OP tree. */
2739/* startop op_free() this to undo. */
2740/* code Short string id of the caller. */
2741{
2742 dSP; /* Make POPBLOCK work. */
2743 PERL_CONTEXT *cx;
2744 SV **newsp;
f987c7de 2745 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2746 I32 optype;
2747 OP dummy;
155aba94 2748 OP *rop;
83ee9e09
GS		 2749 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2750 char *tmpbuf = tbuf;
c277df42 2751 char *safestr;
a3985cdc 2752 int runtime;
40b8d195 2753 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ		 2754
2755 ENTER;
2756 lex_start(sv);
2757 SAVETMPS;
2758 /* switch to eval mode */
2759
923e4eb5 2760 if (IN_PERL_COMPILETIME) {
f4dd75d9 2761 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2762 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2763 }
83ee9e09
GS		 2764 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2765 SV *sv = sv_newmortal();
2766 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2767 code, (unsigned long)++PL_evalseq,
2768 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2769 tmpbuf = SvPVX(sv);
2770 }
2771 else
2772 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2773 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2774 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2775 SAVECOPLINE(&PL_compiling);
57843af0 2776 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2777 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2778 deleting the eval's FILEGV from the stash before gv_check() runs
2779 (i.e. before run-time proper). To work around the coredump that
2780 ensues, we always turn GvMULTI_on for any globals that were
2781 introduced within evals. See force_ident(). GSAR 96-10-12 */
2782 safestr = savepv(tmpbuf);
3280af22 2783 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2784 SAVEHINTS();
d1ca3daa 2785#ifdef OP_IN_REGISTER
6b88bc9c 2786 PL_opsave = op;
d1ca3daa 2787#else
7766f137 2788 SAVEVPTR(PL_op);
d1ca3daa 2789#endif
c277df42 2790
a3985cdc 2791 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2792 runtime = IN_PERL_RUNTIME;
a3985cdc 2793 if (runtime)
d819b83a 2794 runcv = find_runcv(NULL);
a3985cdc 2795
533c011a 2796 PL_op = &dummy;
13b51b79 2797 PL_op->op_type = OP_ENTEREVAL;
533c011a 2798 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2799 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2800 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2801
2802 if (runtime)
2803 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2804 else
2805 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2806 POPBLOCK(cx,PL_curpm);
e84b9f1f 2807 POPEVAL(cx);
c277df42
IZ		 2808
2809 (*startop)->op_type = OP_NULL;
22c35a8c 2810 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2811 lex_end();
f3548bdc
DM		 2812 /* XXX DAPM do this properly one year */
2813 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2814 LEAVE;
923e4eb5 2815 if (IN_PERL_COMPILETIME)
eb160463 2816 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2817#ifdef OP_IN_REGISTER
6b88bc9c 2818 op = PL_opsave;
d1ca3daa 2819#endif
c277df42
IZ		 2820 return rop;
2821}
2822
a3985cdc
DM		 2823
2824/*
2825=for apidoc find_runcv
2826
2827Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2828If db_seqp is non_null, skip CVs that are in the DB package and populate
2829*db_seqp with the cop sequence number at the point that the DB:: code was
2830entered. (allows debuggers to eval in the scope of the breakpoint rather
8006bbc3 2831than in in the scope of the debugger itself).
a3985cdc
DM		 2832
2833=cut
2834*/
2835
2836CV*
d819b83a 2837Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc
DM		 2838{
2839 I32 ix;
2840 PERL_SI *si;
2841 PERL_CONTEXT *cx;
2842
d819b83a
DM		 2843 if (db_seqp)
2844 *db_seqp = PL_curcop->cop_seq;
a3985cdc
DM		 2845 for (si = PL_curstackinfo; si; si = si->si_prev) {
2846 for (ix = si->si_cxix; ix >= 0; ix--) {
2847 cx = &(si->si_cxstack[ix]);
d819b83a
DM		 2848 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2849 CV *cv = cx->blk_sub.cv;
2850 /* skip DB:: code */
2851 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2852 *db_seqp = cx->blk_oldcop->cop_seq;
2853 continue;
2854 }
2855 return cv;
2856 }
a3985cdc
DM		 2857 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2858 return PL_compcv;
2859 }
2860 }
2861 return PL_main_cv;
2862}
2863
2864
2865/* Compile a require/do, an eval '', or a /(?{...})/.
2866 * In the last case, startop is non-null, and contains the address of
2867 * a pointer that should be set to the just-compiled code.
2868 * outside is the lexically enclosing CV (if any) that invoked us.
2869 */
2870
4d1ff10f 2871/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2872STATIC OP *
a3985cdc 2873S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e
LW		 2874{
2875 dSP;
533c011a 2876 OP *saveop = PL_op;
a0d0e21e 2877
6dc8a9e4
IZ		 2878 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2879 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2880 : EVAL_INEVAL);
a0d0e21e 2881
1ce6579f 2882 PUSHMARK(SP);
2883
3280af22
NIS		 2884 SAVESPTR(PL_compcv);
2885 PL_compcv = (CV*)NEWSV(1104,0);
2886 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2887 CvEVAL_on(PL_compcv);
2090ab20
JH		 2888 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2889 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2890
a3985cdc 2891 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2892 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2893
dd2155a4 2894 /* set up a scratch pad */
a0d0e21e 2895
dd2155a4 2896 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2897
07055b4c 2898
26d9b02f 2899 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2900
a0d0e21e
LW		 2901 /* make sure we compile in the right package */
2902
ed094faf 2903 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2904 SAVESPTR(PL_curstash);
ed094faf 2905 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2906 }
3280af22
NIS		 2907 SAVESPTR(PL_beginav);
2908 PL_beginav = newAV();
2909 SAVEFREESV(PL_beginav);
24944567 2910 SAVEI32(PL_error_count);
a0d0e21e
LW		 2911
2912 /* try to compile it */
2913
3280af22
NIS		 2914 PL_eval_root = Nullop;
2915 PL_error_count = 0;
2916 PL_curcop = &PL_compiling;
2917 PL_curcop->cop_arybase = 0;
c277df42 2918 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2919 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2920 else
38a03e6e 2921 sv_setpv(ERRSV,"");
3280af22 2922 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2923 SV **newsp; /* Used by POPBLOCK. */
4d8b06f1 2924 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2925 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2926 STRLEN n_a;
097ee67d 2927
533c011a 2928 PL_op = saveop;
3280af22
NIS		 2929 if (PL_eval_root) {
2930 op_free(PL_eval_root);
2931 PL_eval_root = Nullop;
a0d0e21e 2932 }
3280af22 2933 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2934 if (!startop) {
3280af22 2935 POPBLOCK(cx,PL_curpm);
c277df42 2936 POPEVAL(cx);
c277df42 2937 }
a0d0e21e
LW		 2938 lex_end();
2939 LEAVE;
7a2e2cd6 2940 if (optype == OP_REQUIRE) {
2d8e6c8d 2941 char* msg = SvPVx(ERRSV, n_a);
4d8b06f1
RD		 2942 SV *nsv = cx->blk_eval.old_namesv;
2943 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
27bcc0a7 2944 &PL_sv_undef, 0);
5a844595
GS		 2945 DIE(aTHX_ "%sCompilation failed in require",
2946 *msg ? msg : "Unknown error\n");
2947 }
2948 else if (startop) {
2d8e6c8d 2949 char* msg = SvPVx(ERRSV, n_a);
c277df42 2950
3280af22 2951 POPBLOCK(cx,PL_curpm);
c277df42 2952 POPEVAL(cx);
5a844595
GS		 2953 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2954 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2955 }
9d7f88dd
SR		 2956 else {
2957 char* msg = SvPVx(ERRSV, n_a);
2958 if (!*msg) {
2959 sv_setpv(ERRSV, "Compilation error");
2960 }
2961 }
a0d0e21e
LW		 2962 RETPUSHUNDEF;
2963 }
57843af0 2964 CopLINE_set(&PL_compiling, 0);
c277df42 2965 if (startop) {
3280af22 2966 *startop = PL_eval_root;
c277df42 2967 } else
3280af22 2968 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2969
2970 /* Set the context for this new optree.
2971 * If the last op is an OP_REQUIRE, force scalar context.
2972 * Otherwise, propagate the context from the eval(). */
2973 if (PL_eval_root->op_type == OP_LEAVEEVAL
2974 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2975 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2976 == OP_REQUIRE)
2977 scalar(PL_eval_root);
2978 else if (gimme & G_VOID)
3280af22 2979 scalarvoid(PL_eval_root);
54310121 2980 else if (gimme & G_ARRAY)
3280af22 2981 list(PL_eval_root);
a0d0e21e 2982 else
3280af22 2983 scalar(PL_eval_root);
a0d0e21e
LW		 2984
2985 DEBUG_x(dump_eval());
2986
55497cff 2987 /* Register with debugger: */
84902520 2988 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2989 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2990 if (cv) {
2991 dSP;
924508f0 2992 PUSHMARK(SP);
cc49e20b 2993 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2994 PUTBACK;
864dbfa3 2995 call_sv((SV*)cv, G_DISCARD);
55497cff 2996 }
2997 }
2998
a0d0e21e
LW		 2999 /* compiled okay, so do it */
3000
3280af22
NIS		 3001 CvDEPTH(PL_compcv) = 1;
3002 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3003 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3004 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3005
3280af22 3006 RETURNOP(PL_eval_start);
a0d0e21e
LW		 3007}
3008
a6c40364 3009STATIC PerlIO *
7925835c 3010S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3011{
7925835c 3012#ifndef PERL_DISABLE_PMC
b295d113
TH		 3013 STRLEN namelen = strlen(name);
3014 PerlIO *fp;
3015
7894fbab 3016 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 3017 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 3018 char *pmc = SvPV_nolen(pmcsv);
3019 Stat_t pmstat;
a6c40364
GS		 3020 Stat_t pmcstat;
3021 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3022 fp = PerlIO_open(name, mode);
a6c40364
GS		 3023 }
3024 else {
b295d113 3025 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3026 pmstat.st_mtime < pmcstat.st_mtime)
3027 {
3028 fp = PerlIO_open(pmc, mode);
3029 }
3030 else {
3031 fp = PerlIO_open(name, mode);
3032 }
b295d113 3033 }
a6c40364
GS		 3034 SvREFCNT_dec(pmcsv);
3035 }
3036 else {
3037 fp = PerlIO_open(name, mode);
b295d113 3038 }
b295d113 3039 return fp;
7925835c
RGS		 3040#else
3041 return PerlIO_open(name, mode);
3042#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3043}
3044
a0d0e21e
LW		 3045PP(pp_require)
3046{
39644a26 3047 dSP;
c09156bb 3048 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3049 SV *sv;
3050 char *name;
6132ea6c 3051 STRLEN len;
9c5ffd7c 3052 char *tryname = Nullch;
46fc3d4c 3053 SV *namesv = Nullsv;
a0d0e21e 3054 SV** svp;
986b19de 3055 I32 gimme = GIMME_V;
760ac839 3056 PerlIO *tryrsfp = 0;
2d8e6c8d 3057 STRLEN n_a;
bbed91b5
KF		 3058 int filter_has_file = 0;
3059 GV *filter_child_proc = 0;
3060 SV *filter_state = 0;
3061 SV *filter_sub = 0;
89ccab8c 3062 SV *hook_sv = 0;
6ec9efec
JH		 3063 SV *encoding;
3064 OP *op;
a0d0e21e
LW		 3065
3066 sv = POPs;
d7aa5382
JP		 3067 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3068 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3069 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3070 "v-string in use/require non-portable");
d7aa5382
JP		 3071
3072 sv = new_version(sv);
3073 if (!sv_derived_from(PL_patchlevel, "version"))
3074 (void *)upg_version(PL_patchlevel);
3075 if ( vcmp(sv,PL_patchlevel) > 0 )
014ead4b 3076 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
d7aa5382
JP		 3077 vstringify(sv), vstringify(PL_patchlevel));
3078
4305d8ab 3079 RETPUSHYES;
a0d0e21e 3080 }
6132ea6c
GS		 3081 name = SvPV(sv, len);
3082 if (!(name && len > 0 && *name))
cea2e8a9 3083 DIE(aTHX_ "Null filename used");
4633a7c4 3084 TAINT_PROPER("require");
533c011a 3085 if (PL_op->op_type == OP_REQUIRE &&
27bcc0a7
RGS		 3086 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3087 if (*svp != &PL_sv_undef)
4d8b06f1
RD		 3088 RETPUSHYES;
3089 else
3090 DIE(aTHX_ "Compilation failed in require");
3091 }
a0d0e21e
LW		 3092
3093 /* prepare to compile file */
3094
be4b629d 3095 if (path_is_absolute(name)) {
46fc3d4c 3096 tryname = name;
7925835c 3097 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3098 }
67627c52
JH		 3099#ifdef MACOS_TRADITIONAL
3100 if (!tryrsfp) {
3101 char newname[256];
3102
3103 MacPerl_CanonDir(name, newname, 1);
3104 if (path_is_absolute(newname)) {
3105 tryname = newname;
7925835c 3106 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3107 }
3108 }
3109#endif
be4b629d 3110 if (!tryrsfp) {
3280af22 3111 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3112 I32 i;
748a9306 3113#ifdef VMS
46fc3d4c 3114 char *unixname;
3115 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3116#endif
3117 {
3118 namesv = NEWSV(806, 0);
3119 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3120 SV *dirsv = *av_fetch(ar, i, TRUE);
3121
3122 if (SvROK(dirsv)) {
3123 int count;
3124 SV *loader = dirsv;
3125
e14e2dc8
NC		 3126 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3127 && !sv_isobject(loader))
3128 {
bbed91b5
KF		 3129 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3130 }
3131
b900a521 3132 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3133 PTR2UV(SvRV(dirsv)), name);
bbed91b5
KF		 3134 tryname = SvPVX(namesv);
3135 tryrsfp = 0;
3136
3137 ENTER;
3138 SAVETMPS;
3139 EXTEND(SP, 2);
3140
3141 PUSHMARK(SP);
3142 PUSHs(dirsv);
3143 PUSHs(sv);
3144 PUTBACK;
e982885c
NC		 3145 if (sv_isobject(loader))
3146 count = call_method("INC", G_ARRAY);
3147 else
3148 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3149 SPAGAIN;
3150
3151 if (count > 0) {
3152 int i = 0;
3153 SV *arg;
3154
3155 SP -= count - 1;
3156 arg = SP[i++];
3157
3158 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3159 arg = SvRV(arg);
3160 }
3161
3162 if (SvTYPE(arg) == SVt_PVGV) {
3163 IO *io = GvIO((GV *)arg);
3164
3165 ++filter_has_file;
3166
3167 if (io) {
3168 tryrsfp = IoIFP(io);
50952442 3169 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3170 /* reading from a child process doesn't
3171 nest -- when returning from reading
3172 the inner module, the outer one is
3173 unreadable (closed?) I've tried to
3174 save the gv to manage the lifespan of
3175 the pipe, but this didn't help. XXX */
3176 filter_child_proc = (GV *)arg;
520c758a 3177 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3178 }
3179 else {
3180 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3181 PerlIO_close(IoOFP(io));
3182 }
3183 IoIFP(io) = Nullfp;
3184 IoOFP(io) = Nullfp;
3185 }
3186 }
3187
3188 if (i < count) {
3189 arg = SP[i++];
3190 }
3191 }
3192
3193 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3194 filter_sub = arg;
520c758a 3195 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3196
3197 if (i < count) {
3198 filter_state = SP[i];
520c758a 3199 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3200 }
3201
3202 if (tryrsfp == 0) {
3203 tryrsfp = PerlIO_open("/dev/null",
3204 PERL_SCRIPT_MODE);
3205 }
3206 }
1d06aecd 3207 SP--;
bbed91b5
KF		 3208 }
3209
3210 PUTBACK;
3211 FREETMPS;
3212 LEAVE;
3213
3214 if (tryrsfp) {
89ccab8c 3215 hook_sv = dirsv;
bbed91b5
KF		 3216 break;
3217 }
3218
3219 filter_has_file = 0;
3220 if (filter_child_proc) {
3221 SvREFCNT_dec(filter_child_proc);
3222 filter_child_proc = 0;
3223 }
3224 if (filter_state) {
3225 SvREFCNT_dec(filter_state);
3226 filter_state = 0;
3227 }
3228 if (filter_sub) {
3229 SvREFCNT_dec(filter_sub);
3230 filter_sub = 0;
3231 }
3232 }
3233 else {
be4b629d
CN		 3234 if (!path_is_absolute(name)
3235#ifdef MACOS_TRADITIONAL
3236 /* We consider paths of the form :a:b ambiguous and interpret them first
3237 as global then as local
3238 */
3239 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3240#endif
3241 ) {
bbed91b5 3242 char *dir = SvPVx(dirsv, n_a);
bf4acbe4 3243#ifdef MACOS_TRADITIONAL
67627c52
JH		 3244 char buf1[256];
3245 char buf2[256];
3246
3247 MacPerl_CanonDir(name, buf2, 1);
3248 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3249#else
46fc3d4c 3250#ifdef VMS
bbed91b5
KF		 3251 char *unixdir;
3252 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3253 continue;
3254 sv_setpv(namesv, unixdir);
3255 sv_catpv(namesv, unixname);
748a9306 3256#else
bbed91b5 3257 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3258#endif
bf4acbe4 3259#endif
bbed91b5
KF		 3260 TAINT_PROPER("require");
3261 tryname = SvPVX(namesv);
7925835c 3262 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3263 if (tryrsfp) {
3264 if (tryname[0] == '.' && tryname[1] == '/')
3265 tryname += 2;
3266 break;
3267 }
be4b629d 3268 }
46fc3d4c 3269 }
a0d0e21e
LW		 3270 }
3271 }
3272 }
f4dd75d9 3273 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3274 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3275 SvREFCNT_dec(namesv);
a0d0e21e 3276 if (!tryrsfp) {
533c011a 3277 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 3278 char *msgstr = name;
3279 if (namesv) { /* did we lookup @INC? */
3280 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3281 SV *dirmsgsv = NEWSV(0, 0);
3282 AV *ar = GvAVn(PL_incgv);
3283 I32 i;
3284 sv_catpvn(msg, " in @INC", 8);
3285 if (instr(SvPVX(msg), ".h "))
3286 sv_catpv(msg, " (change .h to .ph maybe?)");
3287 if (instr(SvPVX(msg), ".ph "))
3288 sv_catpv(msg, " (did you run h2ph?)");
3289 sv_catpv(msg, " (@INC contains:");
3290 for (i = 0; i <= AvFILL(ar); i++) {
3291 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3292 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3293 sv_catsv(msg, dirmsgsv);
3294 }
3295 sv_catpvn(msg, ")", 1);
3296 SvREFCNT_dec(dirmsgsv);
3297 msgstr = SvPV_nolen(msg);
2683423c 3298 }
ea071790 3299 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3300 }
3301
3302 RETPUSHUNDEF;
3303 }
d8bfb8bd 3304 else
93189314 3305 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3306
3307 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS		 3308 len = strlen(name);
3309 /* Check whether a hook in @INC has already filled %INC */
3310 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3311 (void)hv_store(GvHVn(PL_incgv), name, len,
3312 (hook_sv ? SvREFCNT_inc(hook_sv)
3313 : newSVpv(CopFILE(&PL_compiling), 0)),
3314 0 );
3315 }
a0d0e21e
LW		 3316
3317 ENTER;
3318 SAVETMPS;
79cb57f6 3319 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3320 SAVEGENERICSV(PL_rsfp_filters);
3321 PL_rsfp_filters = Nullav;
e50aee73 3322
3280af22 3323 PL_rsfp = tryrsfp;
b3ac6de7 3324 SAVEHINTS();
3280af22 3325 PL_hints = 0;
7766f137 3326 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3327 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3328 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3329 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3330 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3331 else if (PL_taint_warn)
3332 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3333 else
d3a7d8c7 3334 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3335 SAVESPTR(PL_compiling.cop_io);
3336 PL_compiling.cop_io = Nullsv;
a0d0e21e 3337
bbed91b5
KF		 3338 if (filter_sub || filter_child_proc) {
3339 SV *datasv = filter_add(run_user_filter, Nullsv);
3340 IoLINES(datasv) = filter_has_file;
3341 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3342 IoTOP_GV(datasv) = (GV *)filter_state;
3343 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3344 }
3345
3346 /* switch to eval mode */
a0d0e21e 3347 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3348 PUSHEVAL(cx, name, Nullgv);
f39bc417 3349 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3350
57843af0
GS		 3351 SAVECOPLINE(&PL_compiling);
3352 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3353
3354 PUTBACK;
6ec9efec
JH		 3355
3356 /* Store and reset encoding. */
3357 encoding = PL_encoding;
3358 PL_encoding = Nullsv;
3359
a3985cdc 3360 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
6ec9efec
JH		 3361
3362 /* Restore encoding. */
3363 PL_encoding = encoding;
3364
3365 return op;
a0d0e21e
LW		 3366}
3367
3368PP(pp_dofile)
3369{
cea2e8a9 3370 return pp_require();
a0d0e21e
LW		 3371}
3372
3373PP(pp_entereval)
3374{
39644a26 3375 dSP;
c09156bb 3376 register PERL_CONTEXT *cx;
a0d0e21e 3377 dPOPss;
3280af22 3378 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3379 char tbuf[TYPE_DIGITS(long) + 12];
3380 char *tmpbuf = tbuf;
fc36a67e 3381 char *safestr;
a0d0e21e 3382 STRLEN len;
55497cff 3383 OP *ret;
a3985cdc 3384 CV* runcv;
d819b83a 3385 U32 seq;
a0d0e21e 3386
16a5162e 3387 if (!SvPV(sv,len))
a0d0e21e 3388 RETPUSHUNDEF;
748a9306 3389 TAINT_PROPER("eval");
a0d0e21e
LW		 3390
3391 ENTER;
a0d0e21e 3392 lex_start(sv);
748a9306 3393 SAVETMPS;
ac27b0f5 3394
a0d0e21e
LW		 3395 /* switch to eval mode */
3396
83ee9e09
GS		 3397 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3398 SV *sv = sv_newmortal();
3399 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3400 (unsigned long)++PL_evalseq,
3401 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3402 tmpbuf = SvPVX(sv);
3403 }
3404 else
3405 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3406 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3407 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3408 SAVECOPLINE(&PL_compiling);
57843af0 3409 CopLINE_set(&PL_compiling, 1);
55497cff 3410 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3411 deleting the eval's FILEGV from the stash before gv_check() runs
3412 (i.e. before run-time proper). To work around the coredump that
3413 ensues, we always turn GvMULTI_on for any globals that were
3414 introduced within evals. See force_ident(). GSAR 96-10-12 */
3415 safestr = savepv(tmpbuf);
3280af22 3416 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3417 SAVEHINTS();
533c011a 3418 PL_hints = PL_op->op_targ;
7766f137 3419 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3420 if (specialWARN(PL_curcop->cop_warnings))
3421 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3422 else {
3423 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3424 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3425 }
ac27b0f5
NIS		 3426 SAVESPTR(PL_compiling.cop_io);
3427 if (specialCopIO(PL_curcop->cop_io))
3428 PL_compiling.cop_io = PL_curcop->cop_io;
3429 else {
3430 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3431 SAVEFREESV(PL_compiling.cop_io);
3432 }
d819b83a
DM		 3433 /* special case: an eval '' executed within the DB package gets lexically
3434 * placed in the first non-DB CV rather than the current CV - this
3435 * allows the debugger to execute code, find lexicals etc, in the
3436 * scope of the code being debugged. Passing &seq gets find_runcv
3437 * to do the dirty work for us */
3438 runcv = find_runcv(&seq);
a0d0e21e 3439
6b35e009 3440 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3441 PUSHEVAL(cx, 0, Nullgv);
f39bc417 3442 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 3443
3444 /* prepare to compile string */
3445
3280af22 3446 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3447 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3448 PUTBACK;
d819b83a 3449 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3450 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3451 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3452 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3453 }
1e422769 3454 return DOCATCH(ret);
a0d0e21e
LW		 3455}
3456
3457PP(pp_leaveeval)
3458{
39644a26 3459 dSP;
a0d0e21e
LW		 3460 register SV **mark;
3461 SV **newsp;
3462 PMOP *newpm;
3463 I32 gimme;
c09156bb 3464 register PERL_CONTEXT *cx;
a0d0e21e 3465 OP *retop;
533c011a 3466 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3467 I32 optype;
3468
3469 POPBLOCK(cx,newpm);
3470 POPEVAL(cx);
f39bc417 3471 retop = cx->blk_eval.retop;
a0d0e21e 3472
a1f49e72 3473 TAINT_NOT;
54310121 3474 if (gimme == G_VOID)
3475 MARK = newsp;
3476 else if (gimme == G_SCALAR) {
3477 MARK = newsp + 1;
3478 if (MARK <= SP) {
3479 if (SvFLAGS(TOPs) & SVs_TEMP)
3480 *MARK = TOPs;
3481 else
3482 *MARK = sv_mortalcopy(TOPs);
3483 }
a0d0e21e 3484 else {
54310121 3485 MEXTEND(mark,0);
3280af22 3486 *MARK = &PL_sv_undef;
a0d0e21e 3487 }
a7ec2b44 3488 SP = MARK;
a0d0e21e
LW		 3489 }
3490 else {
a1f49e72
CS		 3491 /* in case LEAVE wipes old return values */
3492 for (mark = newsp + 1; mark <= SP; mark++) {
3493 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3494 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3495 TAINT_NOT; /* Each item is independent */
3496 }
3497 }
a0d0e21e 3498 }
3280af22 3499 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3500
4fdae800 3501#ifdef DEBUGGING
3280af22 3502 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3503#endif
3280af22 3504 CvDEPTH(PL_compcv) = 0;
f46d017c 3505 lex_end();
4fdae800 3506
1ce6579f 3507 if (optype == OP_REQUIRE &&
924508f0 3508 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3509 {
1ce6579f 3510 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 3511 SV *nsv = cx->blk_eval.old_namesv;
3512 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 3513 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
f46d017c
GS		 3514 /* die_where() did LEAVE, or we won't be here */
3515 }
3516 else {
3517 LEAVE;
3518 if (!(save_flags & OPf_SPECIAL))
3519 sv_setpv(ERRSV,"");
a0d0e21e 3520 }
a0d0e21e
LW		 3521
3522 RETURNOP(retop);
3523}
3524
a0d0e21e
LW		 3525PP(pp_entertry)
3526{
39644a26 3527 dSP;
c09156bb 3528 register PERL_CONTEXT *cx;
54310121 3529 I32 gimme = GIMME_V;
a0d0e21e
LW		 3530
3531 ENTER;
3532 SAVETMPS;
3533
1d76a5c3 3534 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
a0d0e21e 3535 PUSHEVAL(cx, 0, 0);
f39bc417 3536 cx->blk_eval.retop = cLOGOP->op_other->op_next;
a0d0e21e 3537
faef0170 3538 PL_in_eval = EVAL_INEVAL;
38a03e6e 3539 sv_setpv(ERRSV,"");