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