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