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 Encode 2.07
[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,
b5f8cc5c 4 * 2000, 2001, 2002, 2003, 2004, 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 *
864dbfa3 1395Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1396{
2d8e6c8d 1397 STRLEN n_a;
87582a92 1398
3280af22 1399 if (PL_in_eval) {
a0d0e21e 1400 I32 cxix;
c09156bb 1401 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1402 I32 gimme;
1403 SV **newsp;
1404
4e6ea2c3 1405 if (message) {
faef0170 1406 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS		 1407 static char prefix[] = "\t(in cleanup) ";
1408 SV *err = ERRSV;
1409 char *e = Nullch;
1410 if (!SvPOK(err))
1411 sv_setpv(err,"");
1412 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1413 e = SvPV(err, n_a);
1414 e += n_a - msglen;
1415 if (*e != *message || strNE(e,message))
1416 e = Nullch;
1417 }
1418 if (!e) {
1419 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1420 sv_catpvn(err, prefix, sizeof(prefix)-1);
1421 sv_catpvn(err, message, msglen);
e476b1b5 1422 if (ckWARN(WARN_MISC)) {
98eae8f5 1423 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
9014280d 1424 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
4e6ea2c3 1425 }
4633a7c4 1426 }
4633a7c4 1427 }
1aa99e6b 1428 else {
06bf62c7 1429 sv_setpvn(ERRSV, message, msglen);
1aa99e6b 1430 }
4633a7c4 1431 }
4e6ea2c3 1432
5a844595
GS		 1433 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1434 && PL_curstackinfo->si_prev)
1435 {
bac4b2ad 1436 dounwind(-1);
d3acc0f7 1437 POPSTACK;
bac4b2ad 1438 }
e336de0d 1439
a0d0e21e
LW		 1440 if (cxix >= 0) {
1441 I32 optype;
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) {
2d8e6c8d 1469 char* msg = SvPVx(ERRSV, n_a);
4d8b06f1
RD		 1470 SV *nsv = cx->blk_eval.old_namesv;
1471 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
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";
0a76ff65 2251 AV *oldav = Nullav;
a0d0e21e
LW		 2252
2253 label = 0;
533c011a 2254 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2255 SV *sv = POPs;
2d8e6c8d 2256 STRLEN n_a;
a0d0e21e
LW		 2257
2258 /* This egregious kludge implements goto &subroutine */
2259 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2260 I32 cxix;
c09156bb 2261 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2262 CV* cv = (CV*)SvRV(sv);
2263 SV** mark;
2264 I32 items = 0;
2265 I32 oldsave;
2266
e8f7dd13 2267 retry:
4aa0a1f7 2268 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 2269 GV *gv = CvGV(cv);
2270 GV *autogv;
2271 if (gv) {
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. */
5023d17a 2288 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;
d8b46c1b 2307 /* abandon @_ if it got reified */
62b1ebc2 2308 if (AvREAL(av)) {
0a76ff65 2309 oldav = av; /* delay until return */
d8b46c1b
GS		 2310 av = newAV();
2311 av_extend(av, items-1);
2312 AvFLAGS(av) = AVf_REIFY;
dd2155a4 2313 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2314 }
f3a46bf8
DM		 2315 else
2316 CLEAR_ARGARRAY(av);
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;
0a76ff65
DM		 2335 /* For reified @_, delay freeing till return from new sub */
2336 if (oldav)
2337 SAVEFREESV((SV*)oldav);
5023d17a 2338 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2339 if (CvXSUB(cv)) {
67caa1fe 2340#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2341 if (CvOLDSTYLE(cv)) {
20ce7b12 2342 I32 (*fp3)(int,int,int);
924508f0
GS		 2343 while (SP > mark) {
2344 SP[1] = SP[0];
2345 SP--;
a0d0e21e 2346 }
7766f137 2347 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2348 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2349 mark - PL_stack_base + 1,
ecfc5424 2350 items);
3280af22 2351 SP = PL_stack_base + items;
a0d0e21e 2352 }
67caa1fe
GS		 2353 else
2354#endif /* PERL_XSUB_OLDSTYLE */
2355 {
1fa4e549
AD		 2356 SV **newsp;
2357 I32 gimme;
2358
1fa4e549 2359 /* Push a mark for the start of arglist */
ac27b0f5 2360 PUSHMARK(mark);
a45cdc79 2361 PUTBACK;
acfe0abc 2362 (void)(*CvXSUB(cv))(aTHX_ cv);
1fa4e549 2363 /* Pop the current context like a decent sub should */
3280af22 2364 POPBLOCK(cx, PL_curpm);
1fa4e549 2365 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2366 }
2367 LEAVE;
f39bc417
DM		 2368 assert(CxTYPE(cx) == CXt_SUB);
2369 return cx->blk_sub.retop;
a0d0e21e
LW		 2370 }
2371 else {
2372 AV* padlist = CvPADLIST(cv);
6b35e009 2373 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2374 PL_in_eval = cx->blk_eval.old_in_eval;
2375 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2376 cx->cx_type = CXt_SUB;
2377 cx->blk_sub.hasargs = 0;
2378 }
a0d0e21e 2379 cx->blk_sub.cv = cv;
eb160463 2380 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2381
a0d0e21e
LW		 2382 CvDEPTH(cv)++;
2383 if (CvDEPTH(cv) < 2)
2384 (void)SvREFCNT_inc(cv);
dd2155a4 2385 else {
599cee73 2386 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2387 sub_crush_depth(cv);
ff0adf16 2388 pad_push(padlist, CvDEPTH(cv), 1);
a0d0e21e 2389 }
dd2155a4 2390 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2391 if (cx->blk_sub.hasargs)
6d4ff0d2 2392 {
dd2155a4 2393 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2394 SV** ary;
2395
3280af22
NIS		 2396 cx->blk_sub.savearray = GvAV(PL_defgv);
2397 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2398 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2399 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2400
2401 if (items >= AvMAX(av) + 1) {
2402 ary = AvALLOC(av);
2403 if (AvARRAY(av) != ary) {
2404 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2405 SvPVX(av) = (char*)ary;
2406 }
2407 if (items >= AvMAX(av) + 1) {
2408 AvMAX(av) = items - 1;
2409 Renew(ary,items+1,SV*);
2410 AvALLOC(av) = ary;
2411 SvPVX(av) = (char*)ary;
2412 }
2413 }
a45cdc79 2414 ++mark;
a0d0e21e 2415 Copy(mark,AvARRAY(av),items,SV*);
93965878 2416 AvFILLp(av) = items - 1;
d8b46c1b 2417 assert(!AvREAL(av));
a0d0e21e
LW		 2418 while (items--) {
2419 if (*mark)
2420 SvTEMP_off(*mark);
2421 mark++;
2422 }
2423 }
491527d0 2424 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2425 /*
2426 * We do not care about using sv to call CV;
2427 * it's for informational purposes only.
2428 */
3280af22 2429 SV *sv = GvSV(PL_DBsub);
491527d0 2430 CV *gotocv;
ac27b0f5 2431
491527d0 2432 if (PERLDB_SUB_NN) {
7619c85e
RG		 2433 (void)SvUPGRADE(sv, SVt_PVIV);
2434 (void)SvIOK_on(sv);
2435 SAVEIV(SvIVX(sv));
2436 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
491527d0
GS		 2437 } else {
2438 save_item(sv);
2439 gv_efullname3(sv, CvGV(cv), Nullch);
2440 }
2441 if ( PERLDB_GOTO
864dbfa3 2442 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2443 PUSHMARK( PL_stack_sp );
864dbfa3 2444 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2445 PL_stack_sp--;
491527d0 2446 }
1ce6579f 2447 }
a0d0e21e
LW		 2448 RETURNOP(CvSTART(cv));
2449 }
2450 }
1614b0e3 2451 else {
2d8e6c8d 2452 label = SvPV(sv,n_a);
1614b0e3 2453 if (!(do_dump || *label))
cea2e8a9 2454 DIE(aTHX_ must_have_label);
1614b0e3 2455 }
a0d0e21e 2456 }
533c011a 2457 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2458 if (! do_dump)
cea2e8a9 2459 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2460 }
2461 else
2462 label = cPVOP->op_pv;
2463
2464 if (label && *label) {
2465 OP *gotoprobe = 0;
3b2447bc 2466 bool leaving_eval = FALSE;
33d34e4c 2467 bool in_block = FALSE;
a4f3a277 2468 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2469
2470 /* find label */
2471
3280af22 2472 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2473 *enterops = 0;
2474 for (ix = cxstack_ix; ix >= 0; ix--) {
2475 cx = &cxstack[ix];
6b35e009 2476 switch (CxTYPE(cx)) {
a0d0e21e 2477 case CXt_EVAL:
3b2447bc 2478 leaving_eval = TRUE;
971ecbe6 2479 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2480 gotoprobe = (last_eval_cx ?
2481 last_eval_cx->blk_eval.old_eval_root :
2482 PL_eval_root);
2483 last_eval_cx = cx;
9c5794fe
RH		 2484 break;
2485 }
2486 /* else fall through */
a0d0e21e
LW		 2487 case CXt_LOOP:
2488 gotoprobe = cx->blk_oldcop->op_sibling;
2489 break;
2490 case CXt_SUBST:
2491 continue;
2492 case CXt_BLOCK:
33d34e4c 2493 if (ix) {
a0d0e21e 2494 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2495 in_block = TRUE;
2496 } else
3280af22 2497 gotoprobe = PL_main_root;
a0d0e21e 2498 break;
b3933176
CS		 2499 case CXt_SUB:
2500 if (CvDEPTH(cx->blk_sub.cv)) {
2501 gotoprobe = CvROOT(cx->blk_sub.cv);
2502 break;
2503 }
2504 /* FALL THROUGH */
7766f137 2505 case CXt_FORMAT:
0a753a76 2506 case CXt_NULL:
a651a37d 2507 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2508 default:
2509 if (ix)
cea2e8a9 2510 DIE(aTHX_ "panic: goto");
3280af22 2511 gotoprobe = PL_main_root;
a0d0e21e
LW		 2512 break;
2513 }
2b597662
GS		 2514 if (gotoprobe) {
2515 retop = dofindlabel(gotoprobe, label,
2516 enterops, enterops + GOTO_DEPTH);
2517 if (retop)
2518 break;
2519 }
3280af22 2520 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2521 }
2522 if (!retop)
cea2e8a9 2523 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2524
3b2447bc
RH		 2525 /* if we're leaving an eval, check before we pop any frames
2526 that we're not going to punt, otherwise the error
2527 won't be caught */
2528
2529 if (leaving_eval && *enterops && enterops[1]) {
2530 I32 i;
2531 for (i = 1; enterops[i]; i++)
2532 if (enterops[i]->op_type == OP_ENTERITER)
2533 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2534 }
2535
a0d0e21e
LW		 2536 /* pop unwanted frames */
2537
2538 if (ix < cxstack_ix) {
2539 I32 oldsave;
2540
2541 if (ix < 0)
2542 ix = 0;
2543 dounwind(ix);
2544 TOPBLOCK(cx);
3280af22 2545 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2546 LEAVE_SCOPE(oldsave);
2547 }
2548
2549 /* push wanted frames */
2550
748a9306 2551 if (*enterops && enterops[1]) {
533c011a 2552 OP *oldop = PL_op;
33d34e4c
AE		 2553 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2554 for (; enterops[ix]; ix++) {
533c011a 2555 PL_op = enterops[ix];
84902520
TB		 2556 /* Eventually we may want to stack the needed arguments
2557 * for each op. For now, we punt on the hard ones. */
533c011a 2558 if (PL_op->op_type == OP_ENTERITER)
894356b3 2559 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2560 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2561 }
533c011a 2562 PL_op = oldop;
a0d0e21e
LW		 2563 }
2564 }
2565
2566 if (do_dump) {
a5f75d66 2567#ifdef VMS
6b88bc9c 2568 if (!retop) retop = PL_main_start;
a5f75d66 2569#endif
3280af22
NIS		 2570 PL_restartop = retop;
2571 PL_do_undump = TRUE;
a0d0e21e
LW		 2572
2573 my_unexec();
2574
3280af22
NIS		 2575 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2576 PL_do_undump = FALSE;
a0d0e21e
LW		 2577 }
2578
2579 RETURNOP(retop);
2580}
2581
2582PP(pp_exit)
2583{
39644a26 2584 dSP;
a0d0e21e
LW		 2585 I32 anum;
2586
2587 if (MAXARG < 1)
2588 anum = 0;
ff0cee69 2589 else {
a0d0e21e 2590 anum = SvIVx(POPs);
d98f61e7
GS		 2591#ifdef VMS
2592 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2593 anum = 0;
96e176bf 2594 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2595#endif
2596 }
cc3604b1 2597 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2598 my_exit(anum);
3280af22 2599 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2600 RETURN;
2601}
2602
2603#ifdef NOTYET
2604PP(pp_nswitch)
2605{
39644a26 2606 dSP;
65202027 2607 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2608 register I32 match = I_32(value);
2609
2610 if (value < 0.0) {
65202027 2611 if (((NV)match) > value)
a0d0e21e
LW		 2612 --match; /* was fractional--truncate other way */
2613 }
2614 match -= cCOP->uop.scop.scop_offset;
2615 if (match < 0)
2616 match = 0;
2617 else if (match > cCOP->uop.scop.scop_max)
2618 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2619 PL_op = cCOP->uop.scop.scop_next[match];
2620 RETURNOP(PL_op);
a0d0e21e
LW		 2621}
2622
2623PP(pp_cswitch)
2624{
39644a26 2625 dSP;
a0d0e21e
LW		 2626 register I32 match;
2627
6b88bc9c
GS		 2628 if (PL_multiline)
2629 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2630 else {
2d8e6c8d
GS		 2631 STRLEN n_a;
2632 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2633 match -= cCOP->uop.scop.scop_offset;
2634 if (match < 0)
2635 match = 0;
2636 else if (match > cCOP->uop.scop.scop_max)
2637 match = cCOP->uop.scop.scop_max;
6b88bc9c 2638 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2639 }
6b88bc9c 2640 RETURNOP(PL_op);
a0d0e21e
LW		 2641}
2642#endif
2643
2644/* Eval. */
2645
0824fdcb 2646STATIC void
cea2e8a9 2647S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2648{
2649 register char *s = SvPVX(sv);
2650 register char *send = SvPVX(sv) + SvCUR(sv);
2651 register char *t;
2652 register I32 line = 1;
2653
2654 while (s && s < send) {
2655 SV *tmpstr = NEWSV(85,0);
2656
2657 sv_upgrade(tmpstr, SVt_PVMG);
2658 t = strchr(s, '\n');
2659 if (t)
2660 t++;
2661 else
2662 t = send;
2663
2664 sv_setpvn(tmpstr, s, t - s);
2665 av_store(array, line++, tmpstr);
2666 s = t;
2667 }
2668}
2669
14dd3ad8 2670#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2671STATIC void *
cea2e8a9 2672S_docatch_body(pTHX_ va_list args)
312caa8e 2673{
14dd3ad8
GS		 2674 return docatch_body();
2675}
2676#endif
2677
2678STATIC void *
2679S_docatch_body(pTHX)
2680{
cea2e8a9 2681 CALLRUNOPS(aTHX);
312caa8e
CS		 2682 return NULL;
2683}
2684
0824fdcb 2685STATIC OP *
cea2e8a9 2686S_docatch(pTHX_ OP *o)
1e422769 2687{
6224f72b 2688 int ret;
533c011a 2689 OP *oldop = PL_op;
8bffa5f8 2690 OP *retop;
0cdb2077 2691 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2692 dJMPENV;
1e422769 2693
1e422769 2694#ifdef DEBUGGING
54310121 2695 assert(CATCH_GET == TRUE);
1e422769 2696#endif
312caa8e 2697 PL_op = o;
8bffa5f8
DM		 2698
2699 /* Normally, the leavetry at the end of this block of ops will
2700 * pop an op off the return stack and continue there. By setting
2701 * the op to Nullop, we force an exit from the inner runops()
2702 * loop. DAPM.
2703 */
f39bc417
DM		 2704 assert(cxstack_ix >= 0);
2705 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2706 retop = cxstack[cxstack_ix].blk_eval.retop;
2707 cxstack[cxstack_ix].blk_eval.retop = Nullop;
8bffa5f8 2708
14dd3ad8 2709#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2710 redo_body:
db36c5a1 2711 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
14dd3ad8
GS		 2712#else
2713 JMPENV_PUSH(ret);
2714#endif
6224f72b 2715 switch (ret) {
312caa8e 2716 case 0:
14dd3ad8
GS		 2717#ifndef PERL_FLEXIBLE_EXCEPTIONS
2718 redo_body:
2719 docatch_body();
2720#endif
312caa8e
CS		 2721 break;
2722 case 3:
8bffa5f8 2723 /* die caught by an inner eval - continue inner loop */
0cdb2077 2724 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2725 PL_op = PL_restartop;
2726 PL_restartop = 0;
2727 goto redo_body;
2728 }
8bffa5f8
DM		 2729 /* a die in this eval - continue in outer loop */
2730 if (!PL_restartop)
2731 break;
312caa8e
CS		 2732 /* FALL THROUGH */
2733 default:
14dd3ad8 2734 JMPENV_POP;
533c011a 2735 PL_op = oldop;
6224f72b 2736 JMPENV_JUMP(ret);
1e422769 2737 /* NOTREACHED */
1e422769 2738 }
14dd3ad8 2739 JMPENV_POP;
533c011a 2740 PL_op = oldop;
8bffa5f8 2741 return retop;
1e422769 2742}
2743
c277df42 2744OP *
f3548bdc 2745Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
c277df42
IZ		 2746/* sv Text to convert to OP tree. */
2747/* startop op_free() this to undo. */
2748/* code Short string id of the caller. */
2749{
2750 dSP; /* Make POPBLOCK work. */
2751 PERL_CONTEXT *cx;
2752 SV **newsp;
f987c7de 2753 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2754 I32 optype;
2755 OP dummy;
155aba94 2756 OP *rop;
83ee9e09
GS		 2757 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2758 char *tmpbuf = tbuf;
c277df42 2759 char *safestr;
a3985cdc 2760 int runtime;
40b8d195 2761 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ		 2762
2763 ENTER;
2764 lex_start(sv);
2765 SAVETMPS;
2766 /* switch to eval mode */
2767
923e4eb5 2768 if (IN_PERL_COMPILETIME) {
f4dd75d9 2769 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2770 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2771 }
83ee9e09
GS		 2772 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2773 SV *sv = sv_newmortal();
2774 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2775 code, (unsigned long)++PL_evalseq,
2776 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2777 tmpbuf = SvPVX(sv);
2778 }
2779 else
2780 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2781 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2782 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2783 SAVECOPLINE(&PL_compiling);
57843af0 2784 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2785 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2786 deleting the eval's FILEGV from the stash before gv_check() runs
2787 (i.e. before run-time proper). To work around the coredump that
2788 ensues, we always turn GvMULTI_on for any globals that were
2789 introduced within evals. See force_ident(). GSAR 96-10-12 */
2790 safestr = savepv(tmpbuf);
3280af22 2791 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2792 SAVEHINTS();
d1ca3daa 2793#ifdef OP_IN_REGISTER
6b88bc9c 2794 PL_opsave = op;
d1ca3daa 2795#else
7766f137 2796 SAVEVPTR(PL_op);
d1ca3daa 2797#endif
c277df42 2798
a3985cdc 2799 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2800 runtime = IN_PERL_RUNTIME;
a3985cdc 2801 if (runtime)
d819b83a 2802 runcv = find_runcv(NULL);
a3985cdc 2803
533c011a 2804 PL_op = &dummy;
13b51b79 2805 PL_op->op_type = OP_ENTEREVAL;
533c011a 2806 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2807 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2808 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2809
2810 if (runtime)
2811 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2812 else
2813 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2814 POPBLOCK(cx,PL_curpm);
e84b9f1f 2815 POPEVAL(cx);
c277df42
IZ		 2816
2817 (*startop)->op_type = OP_NULL;
22c35a8c 2818 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2819 lex_end();
f3548bdc
DM		 2820 /* XXX DAPM do this properly one year */
2821 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2822 LEAVE;
923e4eb5 2823 if (IN_PERL_COMPILETIME)
eb160463 2824 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2825#ifdef OP_IN_REGISTER
6b88bc9c 2826 op = PL_opsave;
d1ca3daa 2827#endif
c277df42
IZ		 2828 return rop;
2829}
2830
a3985cdc
DM		 2831
2832/*
2833=for apidoc find_runcv
2834
2835Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2836If db_seqp is non_null, skip CVs that are in the DB package and populate
2837*db_seqp with the cop sequence number at the point that the DB:: code was
2838entered. (allows debuggers to eval in the scope of the breakpoint rather
8006bbc3 2839than in in the scope of the debugger itself).
a3985cdc
DM		 2840
2841=cut
2842*/
2843
2844CV*
d819b83a 2845Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc
DM		 2846{
2847 I32 ix;
2848 PERL_SI *si;
2849 PERL_CONTEXT *cx;
2850
d819b83a
DM		 2851 if (db_seqp)
2852 *db_seqp = PL_curcop->cop_seq;
a3985cdc
DM		 2853 for (si = PL_curstackinfo; si; si = si->si_prev) {
2854 for (ix = si->si_cxix; ix >= 0; ix--) {
2855 cx = &(si->si_cxstack[ix]);
d819b83a
DM		 2856 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2857 CV *cv = cx->blk_sub.cv;
2858 /* skip DB:: code */
2859 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2860 *db_seqp = cx->blk_oldcop->cop_seq;
2861 continue;
2862 }
2863 return cv;
2864 }
a3985cdc
DM		 2865 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2866 return PL_compcv;
2867 }
2868 }
2869 return PL_main_cv;
2870}
2871
2872
2873/* Compile a require/do, an eval '', or a /(?{...})/.
2874 * In the last case, startop is non-null, and contains the address of
2875 * a pointer that should be set to the just-compiled code.
2876 * outside is the lexically enclosing CV (if any) that invoked us.
2877 */
2878
4d1ff10f 2879/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2880STATIC OP *
a3985cdc 2881S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e
LW		 2882{
2883 dSP;
533c011a 2884 OP *saveop = PL_op;
a0d0e21e 2885
6dc8a9e4
IZ		 2886 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2887 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2888 : EVAL_INEVAL);
a0d0e21e 2889
1ce6579f 2890 PUSHMARK(SP);
2891
3280af22
NIS		 2892 SAVESPTR(PL_compcv);
2893 PL_compcv = (CV*)NEWSV(1104,0);
2894 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2895 CvEVAL_on(PL_compcv);
2090ab20
JH		 2896 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2897 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2898
a3985cdc 2899 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2900 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2901
dd2155a4 2902 /* set up a scratch pad */
a0d0e21e 2903
dd2155a4 2904 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2905
07055b4c 2906
26d9b02f 2907 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2908
a0d0e21e
LW		 2909 /* make sure we compile in the right package */
2910
ed094faf 2911 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2912 SAVESPTR(PL_curstash);
ed094faf 2913 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2914 }
3280af22
NIS		 2915 SAVESPTR(PL_beginav);
2916 PL_beginav = newAV();
2917 SAVEFREESV(PL_beginav);
24944567 2918 SAVEI32(PL_error_count);
a0d0e21e
LW		 2919
2920 /* try to compile it */
2921
3280af22
NIS		 2922 PL_eval_root = Nullop;
2923 PL_error_count = 0;
2924 PL_curcop = &PL_compiling;
2925 PL_curcop->cop_arybase = 0;
c277df42 2926 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2927 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2928 else
38a03e6e 2929 sv_setpv(ERRSV,"");
3280af22 2930 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2931 SV **newsp; /* Used by POPBLOCK. */
4d8b06f1 2932 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2933 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2934 STRLEN n_a;
097ee67d 2935
533c011a 2936 PL_op = saveop;
3280af22
NIS		 2937 if (PL_eval_root) {
2938 op_free(PL_eval_root);
2939 PL_eval_root = Nullop;
a0d0e21e 2940 }
3280af22 2941 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2942 if (!startop) {
3280af22 2943 POPBLOCK(cx,PL_curpm);
c277df42 2944 POPEVAL(cx);
c277df42 2945 }
a0d0e21e
LW		 2946 lex_end();
2947 LEAVE;
7a2e2cd6 2948 if (optype == OP_REQUIRE) {
2d8e6c8d 2949 char* msg = SvPVx(ERRSV, n_a);
4d8b06f1
RD		 2950 SV *nsv = cx->blk_eval.old_namesv;
2951 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2952 &PL_sv_undef, 0);
5a844595
GS		 2953 DIE(aTHX_ "%sCompilation failed in require",
2954 *msg ? msg : "Unknown error\n");
2955 }
2956 else if (startop) {
2d8e6c8d 2957 char* msg = SvPVx(ERRSV, n_a);
c277df42 2958
3280af22 2959 POPBLOCK(cx,PL_curpm);
c277df42 2960 POPEVAL(cx);
5a844595
GS		 2961 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2962 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2963 }
9d7f88dd
SR		 2964 else {
2965 char* msg = SvPVx(ERRSV, n_a);
2966 if (!*msg) {
2967 sv_setpv(ERRSV, "Compilation error");
2968 }
2969 }
a0d0e21e
LW		 2970 RETPUSHUNDEF;
2971 }
57843af0 2972 CopLINE_set(&PL_compiling, 0);
c277df42 2973 if (startop) {
3280af22 2974 *startop = PL_eval_root;
c277df42 2975 } else
3280af22 2976 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2977
2978 /* Set the context for this new optree.
2979 * If the last op is an OP_REQUIRE, force scalar context.
2980 * Otherwise, propagate the context from the eval(). */
2981 if (PL_eval_root->op_type == OP_LEAVEEVAL
2982 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2983 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2984 == OP_REQUIRE)
2985 scalar(PL_eval_root);
2986 else if (gimme & G_VOID)
3280af22 2987 scalarvoid(PL_eval_root);
54310121 2988 else if (gimme & G_ARRAY)
3280af22 2989 list(PL_eval_root);
a0d0e21e 2990 else
3280af22 2991 scalar(PL_eval_root);
a0d0e21e
LW		 2992
2993 DEBUG_x(dump_eval());
2994
55497cff 2995 /* Register with debugger: */
84902520 2996 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2997 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2998 if (cv) {
2999 dSP;
924508f0 3000 PUSHMARK(SP);
cc49e20b 3001 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 3002 PUTBACK;
864dbfa3 3003 call_sv((SV*)cv, G_DISCARD);
55497cff 3004 }
3005 }
3006
a0d0e21e
LW		 3007 /* compiled okay, so do it */
3008
3280af22
NIS		 3009 CvDEPTH(PL_compcv) = 1;
3010 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3011 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3012 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3013
3280af22 3014 RETURNOP(PL_eval_start);
a0d0e21e
LW		 3015}
3016
a6c40364 3017STATIC PerlIO *
7925835c 3018S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3019{
7925835c 3020#ifndef PERL_DISABLE_PMC
b295d113
TH		 3021 STRLEN namelen = strlen(name);
3022 PerlIO *fp;
3023
7894fbab 3024 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 3025 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 3026 char *pmc = SvPV_nolen(pmcsv);
3027 Stat_t pmstat;
a6c40364
GS		 3028 Stat_t pmcstat;
3029 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3030 fp = PerlIO_open(name, mode);
a6c40364
GS		 3031 }
3032 else {
b295d113 3033 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3034 pmstat.st_mtime < pmcstat.st_mtime)
3035 {
3036 fp = PerlIO_open(pmc, mode);
3037 }
3038 else {
3039 fp = PerlIO_open(name, mode);
3040 }
b295d113 3041 }
a6c40364
GS		 3042 SvREFCNT_dec(pmcsv);
3043 }
3044 else {
3045 fp = PerlIO_open(name, mode);
b295d113 3046 }
b295d113 3047 return fp;
7925835c
RGS		 3048#else
3049 return PerlIO_open(name, mode);
3050#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3051}
3052
a0d0e21e
LW		 3053PP(pp_require)
3054{
39644a26 3055 dSP;
c09156bb 3056 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3057 SV *sv;
3058 char *name;
6132ea6c 3059 STRLEN len;
9c5ffd7c 3060 char *tryname = Nullch;
46fc3d4c 3061 SV *namesv = Nullsv;
a0d0e21e 3062 SV** svp;
986b19de 3063 I32 gimme = GIMME_V;
760ac839 3064 PerlIO *tryrsfp = 0;
2d8e6c8d 3065 STRLEN n_a;
bbed91b5
KF		 3066 int filter_has_file = 0;
3067 GV *filter_child_proc = 0;
3068 SV *filter_state = 0;
3069 SV *filter_sub = 0;
89ccab8c 3070 SV *hook_sv = 0;
6ec9efec
JH		 3071 SV *encoding;
3072 OP *op;
a0d0e21e
LW		 3073
3074 sv = POPs;
d7aa5382
JP		 3075 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3076 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3077 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3078 "v-string in use/require non-portable");
d7aa5382
JP		 3079
3080 sv = new_version(sv);
3081 if (!sv_derived_from(PL_patchlevel, "version"))
3082 (void *)upg_version(PL_patchlevel);
3083 if ( vcmp(sv,PL_patchlevel) > 0 )
3084 DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
3085 vstringify(sv), vstringify(PL_patchlevel));
3086
4305d8ab 3087 RETPUSHYES;
a0d0e21e 3088 }
6132ea6c
GS		 3089 name = SvPV(sv, len);
3090 if (!(name && len > 0 && *name))
cea2e8a9 3091 DIE(aTHX_ "Null filename used");
4633a7c4 3092 TAINT_PROPER("require");
533c011a 3093 if (PL_op->op_type == OP_REQUIRE &&
4d8b06f1
RD		 3094 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3095 if (*svp != &PL_sv_undef)
3096 RETPUSHYES;
3097 else
3098 DIE(aTHX_ "Compilation failed in require");
3099 }
a0d0e21e
LW		 3100
3101 /* prepare to compile file */
3102
be4b629d 3103 if (path_is_absolute(name)) {
46fc3d4c 3104 tryname = name;
7925835c 3105 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3106 }
67627c52
JH		 3107#ifdef MACOS_TRADITIONAL
3108 if (!tryrsfp) {
3109 char newname[256];
3110
3111 MacPerl_CanonDir(name, newname, 1);
3112 if (path_is_absolute(newname)) {
3113 tryname = newname;
7925835c 3114 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3115 }
3116 }
3117#endif
be4b629d 3118 if (!tryrsfp) {
3280af22 3119 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3120 I32 i;
748a9306 3121#ifdef VMS
46fc3d4c 3122 char *unixname;
3123 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3124#endif
3125 {
3126 namesv = NEWSV(806, 0);
3127 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3128 SV *dirsv = *av_fetch(ar, i, TRUE);
3129
3130 if (SvROK(dirsv)) {
3131 int count;
3132 SV *loader = dirsv;
3133
e14e2dc8
NC		 3134 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3135 && !sv_isobject(loader))
3136 {
bbed91b5
KF		 3137 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3138 }
3139
b900a521 3140 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3141 PTR2UV(SvRV(dirsv)), name);
bbed91b5
KF		 3142 tryname = SvPVX(namesv);
3143 tryrsfp = 0;
3144
3145 ENTER;
3146 SAVETMPS;
3147 EXTEND(SP, 2);
3148
3149 PUSHMARK(SP);
3150 PUSHs(dirsv);
3151 PUSHs(sv);
3152 PUTBACK;
e982885c
NC		 3153 if (sv_isobject(loader))
3154 count = call_method("INC", G_ARRAY);
3155 else
3156 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3157 SPAGAIN;
3158
3159 if (count > 0) {
3160 int i = 0;
3161 SV *arg;
3162
3163 SP -= count - 1;
3164 arg = SP[i++];
3165
3166 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3167 arg = SvRV(arg);
3168 }
3169
3170 if (SvTYPE(arg) == SVt_PVGV) {
3171 IO *io = GvIO((GV *)arg);
3172
3173 ++filter_has_file;
3174
3175 if (io) {
3176 tryrsfp = IoIFP(io);
50952442 3177 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3178 /* reading from a child process doesn't
3179 nest -- when returning from reading
3180 the inner module, the outer one is
3181 unreadable (closed?) I've tried to
3182 save the gv to manage the lifespan of
3183 the pipe, but this didn't help. XXX */
3184 filter_child_proc = (GV *)arg;
520c758a 3185 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3186 }
3187 else {
3188 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3189 PerlIO_close(IoOFP(io));
3190 }
3191 IoIFP(io) = Nullfp;
3192 IoOFP(io) = Nullfp;
3193 }
3194 }
3195
3196 if (i < count) {
3197 arg = SP[i++];
3198 }
3199 }
3200
3201 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3202 filter_sub = arg;
520c758a 3203 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3204
3205 if (i < count) {
3206 filter_state = SP[i];
520c758a 3207 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3208 }
3209
3210 if (tryrsfp == 0) {
3211 tryrsfp = PerlIO_open("/dev/null",
3212 PERL_SCRIPT_MODE);
3213 }
3214 }
1d06aecd 3215 SP--;
bbed91b5
KF		 3216 }
3217
3218 PUTBACK;
3219 FREETMPS;
3220 LEAVE;
3221
3222 if (tryrsfp) {
89ccab8c 3223 hook_sv = dirsv;
bbed91b5
KF		 3224 break;
3225 }
3226
3227 filter_has_file = 0;
3228 if (filter_child_proc) {
3229 SvREFCNT_dec(filter_child_proc);
3230 filter_child_proc = 0;
3231 }
3232 if (filter_state) {
3233 SvREFCNT_dec(filter_state);
3234 filter_state = 0;
3235 }
3236 if (filter_sub) {
3237 SvREFCNT_dec(filter_sub);
3238 filter_sub = 0;
3239 }
3240 }
3241 else {
be4b629d
CN		 3242 if (!path_is_absolute(name)
3243#ifdef MACOS_TRADITIONAL
3244 /* We consider paths of the form :a:b ambiguous and interpret them first
3245 as global then as local
3246 */
3247 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3248#endif
3249 ) {
bbed91b5 3250 char *dir = SvPVx(dirsv, n_a);
bf4acbe4 3251#ifdef MACOS_TRADITIONAL
67627c52
JH		 3252 char buf1[256];
3253 char buf2[256];
3254
3255 MacPerl_CanonDir(name, buf2, 1);
3256 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3257#else
46fc3d4c 3258#ifdef VMS
bbed91b5
KF		 3259 char *unixdir;
3260 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3261 continue;
3262 sv_setpv(namesv, unixdir);
3263 sv_catpv(namesv, unixname);
748a9306 3264#else
bbed91b5 3265 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3266#endif
bf4acbe4 3267#endif
bbed91b5
KF		 3268 TAINT_PROPER("require");
3269 tryname = SvPVX(namesv);
7925835c 3270 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3271 if (tryrsfp) {
3272 if (tryname[0] == '.' && tryname[1] == '/')
3273 tryname += 2;
3274 break;
3275 }
be4b629d 3276 }
46fc3d4c 3277 }
a0d0e21e
LW		 3278 }
3279 }
3280 }
f4dd75d9 3281 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3282 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3283 SvREFCNT_dec(namesv);
a0d0e21e 3284 if (!tryrsfp) {
533c011a 3285 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 3286 char *msgstr = name;
3287 if (namesv) { /* did we lookup @INC? */
3288 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3289 SV *dirmsgsv = NEWSV(0, 0);
3290 AV *ar = GvAVn(PL_incgv);
3291 I32 i;
3292 sv_catpvn(msg, " in @INC", 8);
3293 if (instr(SvPVX(msg), ".h "))
3294 sv_catpv(msg, " (change .h to .ph maybe?)");
3295 if (instr(SvPVX(msg), ".ph "))
3296 sv_catpv(msg, " (did you run h2ph?)");
3297 sv_catpv(msg, " (@INC contains:");
3298 for (i = 0; i <= AvFILL(ar); i++) {
3299 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3300 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3301 sv_catsv(msg, dirmsgsv);
3302 }
3303 sv_catpvn(msg, ")", 1);
3304 SvREFCNT_dec(dirmsgsv);
3305 msgstr = SvPV_nolen(msg);
2683423c 3306 }
ea071790 3307 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3308 }
3309
3310 RETPUSHUNDEF;
3311 }
d8bfb8bd 3312 else
93189314 3313 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3314
3315 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS		 3316 len = strlen(name);
3317 /* Check whether a hook in @INC has already filled %INC */
3318 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3319 (void)hv_store(GvHVn(PL_incgv), name, len,
3320 (hook_sv ? SvREFCNT_inc(hook_sv)
3321 : newSVpv(CopFILE(&PL_compiling), 0)),
3322 0 );
3323 }
a0d0e21e
LW		 3324
3325 ENTER;
3326 SAVETMPS;
79cb57f6 3327 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3328 SAVEGENERICSV(PL_rsfp_filters);
3329 PL_rsfp_filters = Nullav;
e50aee73 3330
3280af22 3331 PL_rsfp = tryrsfp;
b3ac6de7 3332 SAVEHINTS();
3280af22 3333 PL_hints = 0;
7766f137 3334 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3335 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3336 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3337 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3338 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3339 else if (PL_taint_warn)
3340 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3341 else
d3a7d8c7 3342 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3343 SAVESPTR(PL_compiling.cop_io);
3344 PL_compiling.cop_io = Nullsv;
a0d0e21e 3345
bbed91b5
KF		 3346 if (filter_sub || filter_child_proc) {
3347 SV *datasv = filter_add(run_user_filter, Nullsv);
3348 IoLINES(datasv) = filter_has_file;
3349 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3350 IoTOP_GV(datasv) = (GV *)filter_state;
3351 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3352 }
3353
3354 /* switch to eval mode */
a0d0e21e 3355 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3356 PUSHEVAL(cx, name, Nullgv);
f39bc417 3357 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3358
57843af0
GS		 3359 SAVECOPLINE(&PL_compiling);
3360 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3361
3362 PUTBACK;
6ec9efec
JH		 3363
3364 /* Store and reset encoding. */
3365 encoding = PL_encoding;
3366 PL_encoding = Nullsv;
3367
a3985cdc 3368 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
6ec9efec
JH		 3369
3370 /* Restore encoding. */
3371 PL_encoding = encoding;
3372
3373 return op;
a0d0e21e
LW		 3374}
3375
3376PP(pp_dofile)
3377{
cea2e8a9 3378 return pp_require();
a0d0e21e
LW		 3379}
3380
3381PP(pp_entereval)
3382{
39644a26 3383 dSP;
c09156bb 3384 register PERL_CONTEXT *cx;
a0d0e21e 3385 dPOPss;
3280af22 3386 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3387 char tbuf[TYPE_DIGITS(long) + 12];
3388 char *tmpbuf = tbuf;
fc36a67e 3389 char *safestr;
a0d0e21e 3390 STRLEN len;
55497cff 3391 OP *ret;
a3985cdc 3392 CV* runcv;
d819b83a 3393 U32 seq;
a0d0e21e 3394
16a5162e 3395 if (!SvPV(sv,len))
a0d0e21e 3396 RETPUSHUNDEF;
748a9306 3397 TAINT_PROPER("eval");
a0d0e21e
LW		 3398
3399 ENTER;
a0d0e21e 3400 lex_start(sv);
748a9306 3401 SAVETMPS;
ac27b0f5 3402
a0d0e21e
LW		 3403 /* switch to eval mode */
3404
83ee9e09
GS		 3405 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3406 SV *sv = sv_newmortal();
3407 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3408 (unsigned long)++PL_evalseq,
3409 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3410 tmpbuf = SvPVX(sv);
3411 }
3412 else
3413 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3414 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3415 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3416 SAVECOPLINE(&PL_compiling);
57843af0 3417 CopLINE_set(&PL_compiling, 1);
55497cff 3418 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3419 deleting the eval's FILEGV from the stash before gv_check() runs
3420 (i.e. before run-time proper). To work around the coredump that
3421 ensues, we always turn GvMULTI_on for any globals that were
3422 introduced within evals. See force_ident(). GSAR 96-10-12 */
3423 safestr = savepv(tmpbuf);
3280af22 3424 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3425 SAVEHINTS();
533c011a 3426 PL_hints = PL_op->op_targ;
7766f137 3427 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3428 if (specialWARN(PL_curcop->cop_warnings))
3429 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3430 else {
3431 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3432 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3433 }
ac27b0f5
NIS		 3434 SAVESPTR(PL_compiling.cop_io);
3435 if (specialCopIO(PL_curcop->cop_io))
3436 PL_compiling.cop_io = PL_curcop->cop_io;
3437 else {
3438 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3439 SAVEFREESV(PL_compiling.cop_io);
3440 }
d819b83a
DM		 3441 /* special case: an eval '' executed within the DB package gets lexically
3442 * placed in the first non-DB CV rather than the current CV - this
3443 * allows the debugger to execute code, find lexicals etc, in the
3444 * scope of the code being debugged. Passing &seq gets find_runcv
3445 * to do the dirty work for us */
3446 runcv = find_runcv(&seq);
a0d0e21e 3447
6b35e009 3448 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3449 PUSHEVAL(cx, 0, Nullgv);
f39bc417 3450 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 3451
3452 /* prepare to compile string */
3453
3280af22 3454 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3455 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3456 PUTBACK;
d819b83a 3457 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3458 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3459 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3460 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3461 }
1e422769 3462 return DOCATCH(ret);
a0d0e21e
LW		 3463}
3464
3465PP(pp_leaveeval)
3466{
39644a26 3467 dSP;
a0d0e21e
LW		 3468 register SV **mark;
3469 SV **newsp;
3470 PMOP *newpm;
3471 I32 gimme;
c09156bb 3472 register PERL_CONTEXT *cx;
a0d0e21e 3473 OP *retop;
533c011a 3474 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3475 I32 optype;
3476
3477 POPBLOCK(cx,newpm);
3478 POPEVAL(cx);
f39bc417 3479 retop = cx->blk_eval.retop;
a0d0e21e 3480
a1f49e72 3481 TAINT_NOT;
54310121 3482 if (gimme == G_VOID)
3483 MARK = newsp;
3484 else if (gimme == G_SCALAR) {
3485 MARK = newsp + 1;
3486 if (MARK <= SP) {
3487 if (SvFLAGS(TOPs) & SVs_TEMP)
3488 *MARK = TOPs;
3489 else
3490 *MARK = sv_mortalcopy(TOPs);
3491 }
a0d0e21e 3492 else {
54310121 3493 MEXTEND(mark,0);
3280af22 3494 *MARK = &PL_sv_undef;
a0d0e21e 3495 }
a7ec2b44 3496 SP = MARK;
a0d0e21e
LW		 3497 }
3498 else {
a1f49e72
CS		 3499 /* in case LEAVE wipes old return values */
3500 for (mark = newsp + 1; mark <= SP; mark++) {
3501 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3502 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3503 TAINT_NOT; /* Each item is independent */
3504 }
3505 }
a0d0e21e 3506 }
3280af22 3507 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3508
4fdae800 3509#ifdef DEBUGGING
3280af22 3510 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3511#endif
3280af22 3512 CvDEPTH(PL_compcv) = 0;
f46d017c 3513 lex_end();
4fdae800 3514
1ce6579f 3515 if (optype == OP_REQUIRE &&
924508f0 3516 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3517 {
1ce6579f 3518 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 3519 SV *nsv = cx->blk_eval.old_namesv;
3520 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 3521 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
f46d017c
GS		 3522 /* die_where() did LEAVE, or we won't be here */
3523 }
3524 else {
3525 LEAVE;
3526 if (!(save_flags & OPf_SPECIAL))
3527 sv_setpv(ERRSV,"");
a0d0e21e 3528 }
a0d0e21e
LW		 3529
3530 RETURNOP(retop);
3531}
3532
a0d0e21e
LW		 3533PP(pp_entertry)
3534{
39644a26 3535 dSP;
c09156bb 3536 register PERL_CONTEXT *cx;
54310121 3537 I32 gimme = GIMME_V;
a0d0e21e
LW		 3538
3539 ENTER;
3540 SAVETMPS;
3541
1d76a5c3 3542 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
a0d0e21e 3543 PUSHEVAL(cx, 0, 0);
f39bc417 3544 cx->blk_eval.retop = cLOGOP->op_other->op_next;