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