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