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