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
Re: [perl #20716] [FIX] scope error with brackets
[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 ||
2018 o->op_type == OP_LEAVETRY)
fc36a67e 2019 {
5dc0d613 2020 *ops++ = cUNOPo->op_first;
fc36a67e 2021 if (ops >= oplimit)
cea2e8a9 2022 Perl_croak(aTHX_ too_deep);
fc36a67e 2023 }
c4aa4e48 2024 *ops = 0;
11343788 2025 if (o->op_flags & OPf_KIDS) {
a0d0e21e 2026 /* First try all the kids at this level, since that's likeliest. */
11343788 2027 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2028 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2029 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2030 return kid;
2031 }
11343788 2032 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2033 if (kid == PL_lastgotoprobe)
a0d0e21e 2034 continue;
ed8d0fe2
SM		 2035 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2036 if (ops == opstack)
2037 *ops++ = kid;
2038 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2039 ops[-1]->op_type == OP_DBSTATE)
2040 ops[-1] = kid;
2041 else
2042 *ops++ = kid;
2043 }
155aba94 2044 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2045 return o;
a0d0e21e
LW		 2046 }
2047 }
c4aa4e48 2048 *ops = 0;
a0d0e21e
LW		 2049 return 0;
2050}
2051
2052PP(pp_dump)
2053{
cea2e8a9 2054 return pp_goto();
a0d0e21e
LW		 2055 /*NOTREACHED*/
2056}
2057
2058PP(pp_goto)
2059{
39644a26 2060 dSP;
a0d0e21e
LW		 2061 OP *retop = 0;
2062 I32 ix;
c09156bb 2063 register PERL_CONTEXT *cx;
fc36a67e 2064#define GOTO_DEPTH 64
2065 OP *enterops[GOTO_DEPTH];
a0d0e21e 2066 char *label;
533c011a 2067 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2068 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 2069
2070 label = 0;
533c011a 2071 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2072 SV *sv = POPs;
2d8e6c8d 2073 STRLEN n_a;
a0d0e21e
LW		 2074
2075 /* This egregious kludge implements goto &subroutine */
2076 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2077 I32 cxix;
c09156bb 2078 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2079 CV* cv = (CV*)SvRV(sv);
2080 SV** mark;
2081 I32 items = 0;
2082 I32 oldsave;
2083
e8f7dd13 2084 retry:
4aa0a1f7 2085 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 2086 GV *gv = CvGV(cv);
2087 GV *autogv;
2088 if (gv) {
2089 SV *tmpstr;
2090 /* autoloaded stub? */
2091 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2092 goto retry;
2093 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2094 GvNAMELEN(gv), FALSE);
2095 if (autogv && (cv = GvCV(autogv)))
2096 goto retry;
2097 tmpstr = sv_newmortal();
2098 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2099 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2100 }
cea2e8a9 2101 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2102 }
2103
a0d0e21e
LW		 2104 /* First do some returnish stuff. */
2105 cxix = dopoptosub(cxstack_ix);
2106 if (cxix < 0)
cea2e8a9 2107 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2108 if (cxix < cxstack_ix)
2109 dounwind(cxix);
2110 TOPBLOCK(cx);
63b28e3f 2111 if (CxREALEVAL(cx))
cea2e8a9 2112 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2113 mark = PL_stack_sp;
d8b46c1b
GS		 2114 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2115 /* put @_ back onto stack */
a0d0e21e
LW		 2116 AV* av = cx->blk_sub.argarray;
2117
93965878 2118 items = AvFILLp(av) + 1;
3280af22
NIS		 2119 PL_stack_sp++;
2120 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2121 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2122 PL_stack_sp += items;
3280af22
NIS		 2123 SvREFCNT_dec(GvAV(PL_defgv));
2124 GvAV(PL_defgv) = cx->blk_sub.savearray;
d8b46c1b 2125 /* abandon @_ if it got reified */
62b1ebc2 2126 if (AvREAL(av)) {
d8b46c1b
GS		 2127 (void)sv_2mortal((SV*)av); /* delay until return */
2128 av = newAV();
2129 av_extend(av, items-1);
2130 AvFLAGS(av) = AVf_REIFY;
dd2155a4 2131 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2132 }
a0d0e21e 2133 }
1fa4e549
AD		 2134 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2135 AV* av;
3280af22 2136 av = GvAV(PL_defgv);
1fa4e549 2137 items = AvFILLp(av) + 1;
3280af22
NIS		 2138 PL_stack_sp++;
2139 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2140 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2141 PL_stack_sp += items;
1fa4e549 2142 }
6b35e009 2143 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2144 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2145 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2146 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2147 LEAVE_SCOPE(oldsave);
2148
2149 /* Now do some callish stuff. */
2150 SAVETMPS;
2151 if (CvXSUB(cv)) {
67caa1fe 2152#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2153 if (CvOLDSTYLE(cv)) {
20ce7b12 2154 I32 (*fp3)(int,int,int);
924508f0
GS		 2155 while (SP > mark) {
2156 SP[1] = SP[0];
2157 SP--;
a0d0e21e 2158 }
7766f137 2159 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2160 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2161 mark - PL_stack_base + 1,
ecfc5424 2162 items);
3280af22 2163 SP = PL_stack_base + items;
a0d0e21e 2164 }
67caa1fe
GS		 2165 else
2166#endif /* PERL_XSUB_OLDSTYLE */
2167 {
1fa4e549
AD		 2168 SV **newsp;
2169 I32 gimme;
2170
3280af22 2171 PL_stack_sp--; /* There is no cv arg. */
1fa4e549 2172 /* Push a mark for the start of arglist */
ac27b0f5 2173 PUSHMARK(mark);
acfe0abc 2174 (void)(*CvXSUB(cv))(aTHX_ cv);
1fa4e549 2175 /* Pop the current context like a decent sub should */
3280af22 2176 POPBLOCK(cx, PL_curpm);
1fa4e549 2177 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2178 }
2179 LEAVE;
2180 return pop_return();
2181 }
2182 else {
2183 AV* padlist = CvPADLIST(cv);
6b35e009 2184 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2185 PL_in_eval = cx->blk_eval.old_in_eval;
2186 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2187 cx->cx_type = CXt_SUB;
2188 cx->blk_sub.hasargs = 0;
2189 }
a0d0e21e 2190 cx->blk_sub.cv = cv;
eb160463 2191 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2192
a0d0e21e
LW		 2193 CvDEPTH(cv)++;
2194 if (CvDEPTH(cv) < 2)
2195 (void)SvREFCNT_inc(cv);
dd2155a4 2196 else {
599cee73 2197 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2198 sub_crush_depth(cv);
dd2155a4 2199 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
a0d0e21e 2200 }
dd2155a4 2201 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2202 if (cx->blk_sub.hasargs)
6d4ff0d2 2203 {
dd2155a4 2204 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2205 SV** ary;
2206
3280af22
NIS		 2207 cx->blk_sub.savearray = GvAV(PL_defgv);
2208 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2209 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2210 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2211 ++mark;
2212
2213 if (items >= AvMAX(av) + 1) {
2214 ary = AvALLOC(av);
2215 if (AvARRAY(av) != ary) {
2216 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2217 SvPVX(av) = (char*)ary;
2218 }
2219 if (items >= AvMAX(av) + 1) {
2220 AvMAX(av) = items - 1;
2221 Renew(ary,items+1,SV*);
2222 AvALLOC(av) = ary;
2223 SvPVX(av) = (char*)ary;
2224 }
2225 }
2226 Copy(mark,AvARRAY(av),items,SV*);
93965878 2227 AvFILLp(av) = items - 1;
d8b46c1b 2228 assert(!AvREAL(av));
a0d0e21e
LW		 2229 while (items--) {
2230 if (*mark)
2231 SvTEMP_off(*mark);
2232 mark++;
2233 }
2234 }
491527d0 2235 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2236 /*
2237 * We do not care about using sv to call CV;
2238 * it's for informational purposes only.
2239 */
3280af22 2240 SV *sv = GvSV(PL_DBsub);
491527d0 2241 CV *gotocv;
ac27b0f5 2242
491527d0 2243 if (PERLDB_SUB_NN) {
56431972 2244 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS		 2245 } else {
2246 save_item(sv);
2247 gv_efullname3(sv, CvGV(cv), Nullch);
2248 }
2249 if ( PERLDB_GOTO
864dbfa3 2250 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2251 PUSHMARK( PL_stack_sp );
864dbfa3 2252 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2253 PL_stack_sp--;
491527d0 2254 }
1ce6579f 2255 }
a0d0e21e
LW		 2256 RETURNOP(CvSTART(cv));
2257 }
2258 }
1614b0e3 2259 else {
2d8e6c8d 2260 label = SvPV(sv,n_a);
1614b0e3 2261 if (!(do_dump || *label))
cea2e8a9 2262 DIE(aTHX_ must_have_label);
1614b0e3 2263 }
a0d0e21e 2264 }
533c011a 2265 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2266 if (! do_dump)
cea2e8a9 2267 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2268 }
2269 else
2270 label = cPVOP->op_pv;
2271
2272 if (label && *label) {
2273 OP *gotoprobe = 0;
3b2447bc 2274 bool leaving_eval = FALSE;
a4f3a277 2275 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2276
2277 /* find label */
2278
3280af22 2279 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2280 *enterops = 0;
2281 for (ix = cxstack_ix; ix >= 0; ix--) {
2282 cx = &cxstack[ix];
6b35e009 2283 switch (CxTYPE(cx)) {
a0d0e21e 2284 case CXt_EVAL:
3b2447bc 2285 leaving_eval = TRUE;
9c5794fe 2286 if (CxREALEVAL(cx)) {
a4f3a277
RH		 2287 gotoprobe = (last_eval_cx ?
2288 last_eval_cx->blk_eval.old_eval_root :
2289 PL_eval_root);
2290 last_eval_cx = cx;
9c5794fe
RH		 2291 break;
2292 }
2293 /* else fall through */
a0d0e21e
LW		 2294 case CXt_LOOP:
2295 gotoprobe = cx->blk_oldcop->op_sibling;
2296 break;
2297 case CXt_SUBST:
2298 continue;
2299 case CXt_BLOCK:
2300 if (ix)
2301 gotoprobe = cx->blk_oldcop->op_sibling;
2302 else
3280af22 2303 gotoprobe = PL_main_root;
a0d0e21e 2304 break;
b3933176
CS		 2305 case CXt_SUB:
2306 if (CvDEPTH(cx->blk_sub.cv)) {
2307 gotoprobe = CvROOT(cx->blk_sub.cv);
2308 break;
2309 }
2310 /* FALL THROUGH */
7766f137 2311 case CXt_FORMAT:
0a753a76 2312 case CXt_NULL:
a651a37d 2313 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2314 default:
2315 if (ix)
cea2e8a9 2316 DIE(aTHX_ "panic: goto");
3280af22 2317 gotoprobe = PL_main_root;
a0d0e21e
LW		 2318 break;
2319 }
2b597662
GS		 2320 if (gotoprobe) {
2321 retop = dofindlabel(gotoprobe, label,
2322 enterops, enterops + GOTO_DEPTH);
2323 if (retop)
2324 break;
2325 }
3280af22 2326 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2327 }
2328 if (!retop)
cea2e8a9 2329 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2330
3b2447bc
RH		 2331 /* if we're leaving an eval, check before we pop any frames
2332 that we're not going to punt, otherwise the error
2333 won't be caught */
2334
2335 if (leaving_eval && *enterops && enterops[1]) {
2336 I32 i;
2337 for (i = 1; enterops[i]; i++)
2338 if (enterops[i]->op_type == OP_ENTERITER)
2339 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2340 }
2341
a0d0e21e
LW		 2342 /* pop unwanted frames */
2343
2344 if (ix < cxstack_ix) {
2345 I32 oldsave;
2346
2347 if (ix < 0)
2348 ix = 0;
2349 dounwind(ix);
2350 TOPBLOCK(cx);
3280af22 2351 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2352 LEAVE_SCOPE(oldsave);
2353 }
2354
2355 /* push wanted frames */
2356
748a9306 2357 if (*enterops && enterops[1]) {
533c011a 2358 OP *oldop = PL_op;
748a9306 2359 for (ix = 1; enterops[ix]; ix++) {
533c011a 2360 PL_op = enterops[ix];
84902520
TB		 2361 /* Eventually we may want to stack the needed arguments
2362 * for each op. For now, we punt on the hard ones. */
533c011a 2363 if (PL_op->op_type == OP_ENTERITER)
894356b3 2364 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2365 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2366 }
533c011a 2367 PL_op = oldop;
a0d0e21e
LW		 2368 }
2369 }
2370
2371 if (do_dump) {
a5f75d66 2372#ifdef VMS
6b88bc9c 2373 if (!retop) retop = PL_main_start;
a5f75d66 2374#endif
3280af22
NIS		 2375 PL_restartop = retop;
2376 PL_do_undump = TRUE;
a0d0e21e
LW		 2377
2378 my_unexec();
2379
3280af22
NIS		 2380 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2381 PL_do_undump = FALSE;
a0d0e21e
LW		 2382 }
2383
2384 RETURNOP(retop);
2385}
2386
2387PP(pp_exit)
2388{
39644a26 2389 dSP;
a0d0e21e
LW		 2390 I32 anum;
2391
2392 if (MAXARG < 1)
2393 anum = 0;
ff0cee69 2394 else {
a0d0e21e 2395 anum = SvIVx(POPs);
d98f61e7
GS		 2396#ifdef VMS
2397 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2398 anum = 0;
96e176bf 2399 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2400#endif
2401 }
cc3604b1 2402 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2403 my_exit(anum);
3280af22 2404 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2405 RETURN;
2406}
2407
2408#ifdef NOTYET
2409PP(pp_nswitch)
2410{
39644a26 2411 dSP;
65202027 2412 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2413 register I32 match = I_32(value);
2414
2415 if (value < 0.0) {
65202027 2416 if (((NV)match) > value)
a0d0e21e
LW		 2417 --match; /* was fractional--truncate other way */
2418 }
2419 match -= cCOP->uop.scop.scop_offset;
2420 if (match < 0)
2421 match = 0;
2422 else if (match > cCOP->uop.scop.scop_max)
2423 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2424 PL_op = cCOP->uop.scop.scop_next[match];
2425 RETURNOP(PL_op);
a0d0e21e
LW		 2426}
2427
2428PP(pp_cswitch)
2429{
39644a26 2430 dSP;
a0d0e21e
LW		 2431 register I32 match;
2432
6b88bc9c
GS		 2433 if (PL_multiline)
2434 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2435 else {
2d8e6c8d
GS		 2436 STRLEN n_a;
2437 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2438 match -= cCOP->uop.scop.scop_offset;
2439 if (match < 0)
2440 match = 0;
2441 else if (match > cCOP->uop.scop.scop_max)
2442 match = cCOP->uop.scop.scop_max;
6b88bc9c 2443 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2444 }
6b88bc9c 2445 RETURNOP(PL_op);
a0d0e21e
LW		 2446}
2447#endif
2448
2449/* Eval. */
2450
0824fdcb 2451STATIC void
cea2e8a9 2452S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2453{
2454 register char *s = SvPVX(sv);
2455 register char *send = SvPVX(sv) + SvCUR(sv);
2456 register char *t;
2457 register I32 line = 1;
2458
2459 while (s && s < send) {
2460 SV *tmpstr = NEWSV(85,0);
2461
2462 sv_upgrade(tmpstr, SVt_PVMG);
2463 t = strchr(s, '\n');
2464 if (t)
2465 t++;
2466 else
2467 t = send;
2468
2469 sv_setpvn(tmpstr, s, t - s);
2470 av_store(array, line++, tmpstr);
2471 s = t;
2472 }
2473}
2474
14dd3ad8 2475#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2476STATIC void *
cea2e8a9 2477S_docatch_body(pTHX_ va_list args)
312caa8e 2478{
14dd3ad8
GS		 2479 return docatch_body();
2480}
2481#endif
2482
2483STATIC void *
2484S_docatch_body(pTHX)
2485{
cea2e8a9 2486 CALLRUNOPS(aTHX);
312caa8e
CS		 2487 return NULL;
2488}
2489
0824fdcb 2490STATIC OP *
cea2e8a9 2491S_docatch(pTHX_ OP *o)
1e422769 2492{
6224f72b 2493 int ret;
533c011a 2494 OP *oldop = PL_op;
8bffa5f8 2495 OP *retop;
0cdb2077 2496 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2497 dJMPENV;
1e422769 2498
1e422769 2499#ifdef DEBUGGING
54310121 2500 assert(CATCH_GET == TRUE);
1e422769 2501#endif
312caa8e 2502 PL_op = o;
8bffa5f8
DM		 2503
2504 /* Normally, the leavetry at the end of this block of ops will
2505 * pop an op off the return stack and continue there. By setting
2506 * the op to Nullop, we force an exit from the inner runops()
2507 * loop. DAPM.
2508 */
2509 retop = pop_return();
2510 push_return(Nullop);
2511
14dd3ad8 2512#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2513 redo_body:
db36c5a1 2514 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
14dd3ad8
GS		 2515#else
2516 JMPENV_PUSH(ret);
2517#endif
6224f72b 2518 switch (ret) {
312caa8e 2519 case 0:
14dd3ad8
GS		 2520#ifndef PERL_FLEXIBLE_EXCEPTIONS
2521 redo_body:
2522 docatch_body();
2523#endif
312caa8e
CS		 2524 break;
2525 case 3:
8bffa5f8 2526 /* die caught by an inner eval - continue inner loop */
0cdb2077 2527 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2528 PL_op = PL_restartop;
2529 PL_restartop = 0;
2530 goto redo_body;
2531 }
8bffa5f8
DM		 2532 /* a die in this eval - continue in outer loop */
2533 if (!PL_restartop)
2534 break;
312caa8e
CS		 2535 /* FALL THROUGH */
2536 default:
14dd3ad8 2537 JMPENV_POP;
533c011a 2538 PL_op = oldop;
6224f72b 2539 JMPENV_JUMP(ret);
1e422769 2540 /* NOTREACHED */
1e422769 2541 }
14dd3ad8 2542 JMPENV_POP;
533c011a 2543 PL_op = oldop;
8bffa5f8 2544 return retop;
1e422769 2545}
2546
c277df42 2547OP *
f3548bdc 2548Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
c277df42
IZ		 2549/* sv Text to convert to OP tree. */
2550/* startop op_free() this to undo. */
2551/* code Short string id of the caller. */
2552{
2553 dSP; /* Make POPBLOCK work. */
2554 PERL_CONTEXT *cx;
2555 SV **newsp;
f987c7de 2556 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2557 I32 optype;
2558 OP dummy;
155aba94 2559 OP *rop;
83ee9e09
GS		 2560 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2561 char *tmpbuf = tbuf;
c277df42 2562 char *safestr;
a3985cdc 2563 int runtime;
40b8d195 2564 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ		 2565
2566 ENTER;
2567 lex_start(sv);
2568 SAVETMPS;
2569 /* switch to eval mode */
2570
cbce877f 2571 if (PL_curcop == &PL_compiling) {
f4dd75d9 2572 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2573 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2574 }
83ee9e09
GS		 2575 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2576 SV *sv = sv_newmortal();
2577 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2578 code, (unsigned long)++PL_evalseq,
2579 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2580 tmpbuf = SvPVX(sv);
2581 }
2582 else
2583 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2584 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2585 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2586 SAVECOPLINE(&PL_compiling);
57843af0 2587 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2588 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2589 deleting the eval's FILEGV from the stash before gv_check() runs
2590 (i.e. before run-time proper). To work around the coredump that
2591 ensues, we always turn GvMULTI_on for any globals that were
2592 introduced within evals. See force_ident(). GSAR 96-10-12 */
2593 safestr = savepv(tmpbuf);
3280af22 2594 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2595 SAVEHINTS();
d1ca3daa 2596#ifdef OP_IN_REGISTER
6b88bc9c 2597 PL_opsave = op;
d1ca3daa 2598#else
7766f137 2599 SAVEVPTR(PL_op);
d1ca3daa 2600#endif
1aa99e6b 2601 PL_hints &= HINT_UTF8;
c277df42 2602
a3985cdc
DM		 2603 /* we get here either during compilation, or via pp_regcomp at runtime */
2604 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2605 if (runtime)
d819b83a 2606 runcv = find_runcv(NULL);
a3985cdc 2607
533c011a 2608 PL_op = &dummy;
13b51b79 2609 PL_op->op_type = OP_ENTEREVAL;
533c011a 2610 PL_op->op_flags = 0; /* Avoid uninit warning. */
160cb429 2611 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
cc49e20b 2612 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2613
2614 if (runtime)
2615 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2616 else
2617 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2618 POPBLOCK(cx,PL_curpm);
e84b9f1f 2619 POPEVAL(cx);
c277df42
IZ		 2620
2621 (*startop)->op_type = OP_NULL;
22c35a8c 2622 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2623 lex_end();
f3548bdc
DM		 2624 /* XXX DAPM do this properly one year */
2625 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2626 LEAVE;
13b51b79 2627 if (PL_curcop == &PL_compiling)
eb160463 2628 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2629#ifdef OP_IN_REGISTER
6b88bc9c 2630 op = PL_opsave;
d1ca3daa 2631#endif
c277df42
IZ		 2632 return rop;
2633}
2634
a3985cdc
DM		 2635
2636/*
2637=for apidoc find_runcv
2638
2639Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2640If db_seqp is non_null, skip CVs that are in the DB package and populate
2641*db_seqp with the cop sequence number at the point that the DB:: code was
2642entered. (allows debuggers to eval in the scope of the breakpoint rather
2643than in in the scope of the debuger itself).
a3985cdc
DM		 2644
2645=cut
2646*/
2647
2648CV*
d819b83a 2649Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc
DM		 2650{
2651 I32 ix;
2652 PERL_SI *si;
2653 PERL_CONTEXT *cx;
2654
d819b83a
DM		 2655 if (db_seqp)
2656 *db_seqp = PL_curcop->cop_seq;
a3985cdc
DM		 2657 for (si = PL_curstackinfo; si; si = si->si_prev) {
2658 for (ix = si->si_cxix; ix >= 0; ix--) {
2659 cx = &(si->si_cxstack[ix]);
d819b83a
DM		 2660 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2661 CV *cv = cx->blk_sub.cv;
2662 /* skip DB:: code */
2663 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2664 *db_seqp = cx->blk_oldcop->cop_seq;
2665 continue;
2666 }
2667 return cv;
2668 }
a3985cdc
DM		 2669 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2670 return PL_compcv;
2671 }
2672 }
2673 return PL_main_cv;
2674}
2675
2676
2677/* Compile a require/do, an eval '', or a /(?{...})/.
2678 * In the last case, startop is non-null, and contains the address of
2679 * a pointer that should be set to the just-compiled code.
2680 * outside is the lexically enclosing CV (if any) that invoked us.
2681 */
2682
4d1ff10f 2683/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2684STATIC OP *
a3985cdc 2685S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e
LW		 2686{
2687 dSP;
533c011a 2688 OP *saveop = PL_op;
a0d0e21e 2689
6dc8a9e4
IZ		 2690 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2691 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2692 : EVAL_INEVAL);
a0d0e21e 2693
1ce6579f 2694 PUSHMARK(SP);
2695
3280af22
NIS		 2696 SAVESPTR(PL_compcv);
2697 PL_compcv = (CV*)NEWSV(1104,0);
2698 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2699 CvEVAL_on(PL_compcv);
2090ab20
JH		 2700 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2701 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2702
a3985cdc 2703 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2704 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2705
dd2155a4 2706 /* set up a scratch pad */
a0d0e21e 2707
dd2155a4 2708 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2709
07055b4c 2710
26d9b02f 2711 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2712
a0d0e21e
LW		 2713 /* make sure we compile in the right package */
2714
ed094faf 2715 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2716 SAVESPTR(PL_curstash);
ed094faf 2717 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2718 }
3280af22
NIS		 2719 SAVESPTR(PL_beginav);
2720 PL_beginav = newAV();
2721 SAVEFREESV(PL_beginav);
24944567 2722 SAVEI32(PL_error_count);
a0d0e21e
LW		 2723
2724 /* try to compile it */
2725
3280af22
NIS		 2726 PL_eval_root = Nullop;
2727 PL_error_count = 0;
2728 PL_curcop = &PL_compiling;
2729 PL_curcop->cop_arybase = 0;
c277df42 2730 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2731 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2732 else
38a03e6e 2733 sv_setpv(ERRSV,"");
3280af22 2734 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2735 SV **newsp;
2736 I32 gimme;
c09156bb 2737 PERL_CONTEXT *cx;
c277df42 2738 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2739 STRLEN n_a;
097ee67d 2740
533c011a 2741 PL_op = saveop;
3280af22
NIS		 2742 if (PL_eval_root) {
2743 op_free(PL_eval_root);
2744 PL_eval_root = Nullop;
a0d0e21e 2745 }
3280af22 2746 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2747 if (!startop) {
3280af22 2748 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2749 POPEVAL(cx);
2750 pop_return();
2751 }
a0d0e21e
LW		 2752 lex_end();
2753 LEAVE;
7a2e2cd6 2754 if (optype == OP_REQUIRE) {
2d8e6c8d 2755 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 2756 DIE(aTHX_ "%sCompilation failed in require",
2757 *msg ? msg : "Unknown error\n");
2758 }
2759 else if (startop) {
2d8e6c8d 2760 char* msg = SvPVx(ERRSV, n_a);
c277df42 2761
3280af22 2762 POPBLOCK(cx,PL_curpm);
c277df42 2763 POPEVAL(cx);
5a844595
GS		 2764 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2765 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2766 }
9d7f88dd
SR		 2767 else {
2768 char* msg = SvPVx(ERRSV, n_a);
2769 if (!*msg) {
2770 sv_setpv(ERRSV, "Compilation error");
2771 }
2772 }
a0d0e21e
LW		 2773 RETPUSHUNDEF;
2774 }
57843af0 2775 CopLINE_set(&PL_compiling, 0);
c277df42 2776 if (startop) {
3280af22 2777 *startop = PL_eval_root;
c277df42 2778 } else
3280af22 2779 SAVEFREEOP(PL_eval_root);
54310121 2780 if (gimme & G_VOID)
3280af22 2781 scalarvoid(PL_eval_root);
54310121 2782 else if (gimme & G_ARRAY)
3280af22 2783 list(PL_eval_root);
a0d0e21e 2784 else
3280af22 2785 scalar(PL_eval_root);
a0d0e21e
LW		 2786
2787 DEBUG_x(dump_eval());
2788
55497cff 2789 /* Register with debugger: */
84902520 2790 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2791 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2792 if (cv) {
2793 dSP;
924508f0 2794 PUSHMARK(SP);
cc49e20b 2795 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2796 PUTBACK;
864dbfa3 2797 call_sv((SV*)cv, G_DISCARD);
55497cff 2798 }
2799 }
2800
a0d0e21e
LW		 2801 /* compiled okay, so do it */
2802
3280af22
NIS		 2803 CvDEPTH(PL_compcv) = 1;
2804 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2805 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 2806 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 2807
3280af22 2808 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2809}
2810
a6c40364 2811STATIC PerlIO *
cea2e8a9 2812S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2813{
2814 STRLEN namelen = strlen(name);
2815 PerlIO *fp;
2816
7894fbab 2817 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2818 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2819 char *pmc = SvPV_nolen(pmcsv);
2820 Stat_t pmstat;
a6c40364
GS		 2821 Stat_t pmcstat;
2822 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2823 fp = PerlIO_open(name, mode);
a6c40364
GS		 2824 }
2825 else {
b295d113 2826 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2827 pmstat.st_mtime < pmcstat.st_mtime)
2828 {
2829 fp = PerlIO_open(pmc, mode);
2830 }
2831 else {
2832 fp = PerlIO_open(name, mode);
2833 }
b295d113 2834 }
a6c40364
GS		 2835 SvREFCNT_dec(pmcsv);
2836 }
2837 else {
2838 fp = PerlIO_open(name, mode);
b295d113 2839 }
b295d113
TH		 2840 return fp;
2841}
2842
a0d0e21e
LW		 2843PP(pp_require)
2844{
39644a26 2845 dSP;
c09156bb 2846 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2847 SV *sv;
2848 char *name;
6132ea6c 2849 STRLEN len;
9c5ffd7c 2850 char *tryname = Nullch;
46fc3d4c 2851 SV *namesv = Nullsv;
a0d0e21e 2852 SV** svp;
986b19de 2853 I32 gimme = GIMME_V;
760ac839 2854 PerlIO *tryrsfp = 0;
2d8e6c8d 2855 STRLEN n_a;
bbed91b5
KF		 2856 int filter_has_file = 0;
2857 GV *filter_child_proc = 0;
2858 SV *filter_state = 0;
2859 SV *filter_sub = 0;
89ccab8c 2860 SV *hook_sv = 0;
6ec9efec
JH		 2861 SV *encoding;
2862 OP *op;
a0d0e21e
LW		 2863
2864 sv = POPs;
d4a8e56c 2865 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
f684db92 2866 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
4305d8ab 2867 UV rev = 0, ver = 0, sver = 0;
ba210ebe 2868 STRLEN len;
a7cb1f99
GS		 2869 U8 *s = (U8*)SvPVX(sv);
2870 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2871 if (s < end) {
9041c2e3 2872 rev = utf8n_to_uvchr(s, end - s, &len, 0);
a7cb1f99
GS		 2873 s += len;
2874 if (s < end) {
9041c2e3 2875 ver = utf8n_to_uvchr(s, end - s, &len, 0);
a7cb1f99
GS		 2876 s += len;
2877 if (s < end)
9041c2e3 2878 sver = utf8n_to_uvchr(s, end - s, &len, 0);
a7cb1f99 2879 }
a7cb1f99 2880 }
a7cb1f99
GS		 2881 if (PERL_REVISION < rev
2882 || (PERL_REVISION == rev
2883 && (PERL_VERSION < ver
2884 || (PERL_VERSION == ver
2885 && PERL_SUBVERSION < sver))))
2886 {
cc507455 2887 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
894356b3 2888 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS		 2889 PERL_VERSION, PERL_SUBVERSION);
2890 }
e3407aba 2891 if (ckWARN(WARN_PORTABLE))
9014280d 2892 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 2893 "v-string in use/require non-portable");
4305d8ab 2894 RETPUSHYES;
a7cb1f99
GS		 2895 }
2896 else if (!SvPOKp(sv)) { /* require 5.005_03 */
a7cb1f99
GS		 2897 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2898 + ((NV)PERL_SUBVERSION/(NV)1000000)
2899 + 0.00000099 < SvNV(sv))
2900 {
dbe7b177
GS		 2901 NV nrev = SvNV(sv);
2902 UV rev = (UV)nrev;
2903 NV nver = (nrev - rev) * 1000;
2904 UV ver = (UV)(nver + 0.0009);
2905 NV nsver = (nver - ver) * 1000;
2906 UV sver = (UV)(nsver + 0.0009);
2907
cc507455
GS		 2908 /* help out with the "use 5.6" confusion */
2909 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
fd7c7598
PN		 2910 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2911 " (did you mean v%"UVuf".%03"UVuf"?)--"
2912 "this is only v%d.%d.%d, stopped",
5dacba13
PN		 2913 rev, ver, sver, rev, ver/100,
2914 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
cc507455
GS		 2915 }
2916 else {
2917 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2918 "this is only v%d.%d.%d, stopped",
2919 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2920 PERL_SUBVERSION);
2921 }
a7cb1f99 2922 }
4305d8ab 2923 RETPUSHYES;
a7cb1f99 2924 }
a0d0e21e 2925 }
6132ea6c
GS		 2926 name = SvPV(sv, len);
2927 if (!(name && len > 0 && *name))
cea2e8a9 2928 DIE(aTHX_ "Null filename used");
4633a7c4 2929 TAINT_PROPER("require");
533c011a 2930 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2931 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2932 *svp != &PL_sv_undef)
a0d0e21e
LW		 2933 RETPUSHYES;
2934
2935 /* prepare to compile file */
2936
be4b629d 2937 if (path_is_absolute(name)) {
46fc3d4c 2938 tryname = name;
a6c40364 2939 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
bf4acbe4 2940 }
67627c52
JH		 2941#ifdef MACOS_TRADITIONAL
2942 if (!tryrsfp) {
2943 char newname[256];
2944
2945 MacPerl_CanonDir(name, newname, 1);
2946 if (path_is_absolute(newname)) {
2947 tryname = newname;
2948 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2949 }
2950 }
2951#endif
be4b629d 2952 if (!tryrsfp) {
3280af22 2953 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2954 I32 i;
748a9306 2955#ifdef VMS
46fc3d4c 2956 char *unixname;
2957 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2958#endif
2959 {
2960 namesv = NEWSV(806, 0);
2961 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 2962 SV *dirsv = *av_fetch(ar, i, TRUE);
2963
2964 if (SvROK(dirsv)) {
2965 int count;
2966 SV *loader = dirsv;
2967
e14e2dc8
NC		 2968 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2969 && !sv_isobject(loader))
2970 {
bbed91b5
KF		 2971 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2972 }
2973
b900a521 2974 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 2975 PTR2UV(SvRV(dirsv)), name);
bbed91b5
KF		 2976 tryname = SvPVX(namesv);
2977 tryrsfp = 0;
2978
2979 ENTER;
2980 SAVETMPS;
2981 EXTEND(SP, 2);
2982
2983 PUSHMARK(SP);
2984 PUSHs(dirsv);
2985 PUSHs(sv);
2986 PUTBACK;
e982885c
NC		 2987 if (sv_isobject(loader))
2988 count = call_method("INC", G_ARRAY);
2989 else
2990 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 2991 SPAGAIN;
2992
2993 if (count > 0) {
2994 int i = 0;
2995 SV *arg;
2996
2997 SP -= count - 1;
2998 arg = SP[i++];
2999
3000 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3001 arg = SvRV(arg);
3002 }
3003
3004 if (SvTYPE(arg) == SVt_PVGV) {
3005 IO *io = GvIO((GV *)arg);
3006
3007 ++filter_has_file;
3008
3009 if (io) {
3010 tryrsfp = IoIFP(io);
50952442 3011 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3012 /* reading from a child process doesn't
3013 nest -- when returning from reading
3014 the inner module, the outer one is
3015 unreadable (closed?) I've tried to
3016 save the gv to manage the lifespan of
3017 the pipe, but this didn't help. XXX */
3018 filter_child_proc = (GV *)arg;
520c758a 3019 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3020 }
3021 else {
3022 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3023 PerlIO_close(IoOFP(io));
3024 }
3025 IoIFP(io) = Nullfp;
3026 IoOFP(io) = Nullfp;
3027 }
3028 }
3029
3030 if (i < count) {
3031 arg = SP[i++];
3032 }
3033 }
3034
3035 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3036 filter_sub = arg;
520c758a 3037 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3038
3039 if (i < count) {
3040 filter_state = SP[i];
520c758a 3041 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3042 }
3043
3044 if (tryrsfp == 0) {
3045 tryrsfp = PerlIO_open("/dev/null",
3046 PERL_SCRIPT_MODE);
3047 }
3048 }
3049 }
3050
3051 PUTBACK;
3052 FREETMPS;
3053 LEAVE;
3054
3055 if (tryrsfp) {
89ccab8c 3056 hook_sv = dirsv;
bbed91b5
KF		 3057 break;
3058 }
3059
3060 filter_has_file = 0;
3061 if (filter_child_proc) {
3062 SvREFCNT_dec(filter_child_proc);
3063 filter_child_proc = 0;
3064 }
3065 if (filter_state) {
3066 SvREFCNT_dec(filter_state);
3067 filter_state = 0;
3068 }
3069 if (filter_sub) {
3070 SvREFCNT_dec(filter_sub);
3071 filter_sub = 0;
3072 }
3073 }
3074 else {
be4b629d
CN		 3075 if (!path_is_absolute(name)
3076#ifdef MACOS_TRADITIONAL
3077 /* We consider paths of the form :a:b ambiguous and interpret them first
3078 as global then as local
3079 */
3080 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3081#endif
3082 ) {
bbed91b5 3083 char *dir = SvPVx(dirsv, n_a);
bf4acbe4 3084#ifdef MACOS_TRADITIONAL
67627c52
JH		 3085 char buf1[256];
3086 char buf2[256];
3087
3088 MacPerl_CanonDir(name, buf2, 1);
3089 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3090#else
46fc3d4c 3091#ifdef VMS
bbed91b5
KF		 3092 char *unixdir;
3093 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3094 continue;
3095 sv_setpv(namesv, unixdir);
3096 sv_catpv(namesv, unixname);
748a9306 3097#else
bbed91b5 3098 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3099#endif
bf4acbe4 3100#endif
bbed91b5
KF		 3101 TAINT_PROPER("require");
3102 tryname = SvPVX(namesv);
3103 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3104 if (tryrsfp) {
3105 if (tryname[0] == '.' && tryname[1] == '/')
3106 tryname += 2;
3107 break;
3108 }
be4b629d 3109 }
46fc3d4c 3110 }
a0d0e21e
LW		 3111 }
3112 }
3113 }
f4dd75d9 3114 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3115 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3116 SvREFCNT_dec(namesv);
a0d0e21e 3117 if (!tryrsfp) {
533c011a 3118 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 3119 char *msgstr = name;
3120 if (namesv) { /* did we lookup @INC? */
3121 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3122 SV *dirmsgsv = NEWSV(0, 0);
3123 AV *ar = GvAVn(PL_incgv);
3124 I32 i;
3125 sv_catpvn(msg, " in @INC", 8);
3126 if (instr(SvPVX(msg), ".h "))
3127 sv_catpv(msg, " (change .h to .ph maybe?)");
3128 if (instr(SvPVX(msg), ".ph "))
3129 sv_catpv(msg, " (did you run h2ph?)");
3130 sv_catpv(msg, " (@INC contains:");
3131 for (i = 0; i <= AvFILL(ar); i++) {
3132 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3133 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3134 sv_catsv(msg, dirmsgsv);
3135 }
3136 sv_catpvn(msg, ")", 1);
3137 SvREFCNT_dec(dirmsgsv);
3138 msgstr = SvPV_nolen(msg);
2683423c 3139 }
ea071790 3140 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3141 }
3142
3143 RETPUSHUNDEF;
3144 }
d8bfb8bd 3145 else
93189314 3146 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3147
3148 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS		 3149 len = strlen(name);
3150 /* Check whether a hook in @INC has already filled %INC */
3151 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3152 (void)hv_store(GvHVn(PL_incgv), name, len,
3153 (hook_sv ? SvREFCNT_inc(hook_sv)
3154 : newSVpv(CopFILE(&PL_compiling), 0)),
3155 0 );
3156 }
a0d0e21e
LW		 3157
3158 ENTER;
3159 SAVETMPS;
79cb57f6 3160 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3161 SAVEGENERICSV(PL_rsfp_filters);
3162 PL_rsfp_filters = Nullav;
e50aee73 3163
3280af22 3164 PL_rsfp = tryrsfp;
b3ac6de7 3165 SAVEHINTS();
3280af22 3166 PL_hints = 0;
7766f137 3167 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3168 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3169 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3170 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3171 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3172 else if (PL_taint_warn)
3173 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3174 else
d3a7d8c7 3175 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3176 SAVESPTR(PL_compiling.cop_io);
3177 PL_compiling.cop_io = Nullsv;
a0d0e21e 3178
bbed91b5
KF		 3179 if (filter_sub || filter_child_proc) {
3180 SV *datasv = filter_add(run_user_filter, Nullsv);
3181 IoLINES(datasv) = filter_has_file;
3182 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3183 IoTOP_GV(datasv) = (GV *)filter_state;
3184 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3185 }
3186
3187 /* switch to eval mode */
533c011a 3188 push_return(PL_op->op_next);
a0d0e21e 3189 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3190 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3191
57843af0
GS		 3192 SAVECOPLINE(&PL_compiling);
3193 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3194
3195 PUTBACK;
6ec9efec
JH		 3196
3197 /* Store and reset encoding. */
3198 encoding = PL_encoding;
3199 PL_encoding = Nullsv;
3200
a3985cdc 3201 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
6ec9efec
JH		 3202
3203 /* Restore encoding. */
3204 PL_encoding = encoding;
3205
3206 return op;
a0d0e21e
LW		 3207}
3208
3209PP(pp_dofile)
3210{
cea2e8a9 3211 return pp_require();
a0d0e21e
LW		 3212}
3213
3214PP(pp_entereval)
3215{
39644a26 3216 dSP;
c09156bb 3217 register PERL_CONTEXT *cx;
a0d0e21e 3218 dPOPss;
3280af22 3219 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3220 char tbuf[TYPE_DIGITS(long) + 12];
3221 char *tmpbuf = tbuf;
fc36a67e 3222 char *safestr;
a0d0e21e 3223 STRLEN len;
55497cff 3224 OP *ret;
a3985cdc 3225 CV* runcv;
d819b83a 3226 U32 seq;
a0d0e21e 3227
16a5162e 3228 if (!SvPV(sv,len))
a0d0e21e 3229 RETPUSHUNDEF;
748a9306 3230 TAINT_PROPER("eval");
a0d0e21e
LW		 3231
3232 ENTER;
a0d0e21e 3233 lex_start(sv);
748a9306 3234 SAVETMPS;
ac27b0f5 3235
a0d0e21e
LW		 3236 /* switch to eval mode */
3237
83ee9e09
GS		 3238 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3239 SV *sv = sv_newmortal();
3240 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3241 (unsigned long)++PL_evalseq,
3242 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3243 tmpbuf = SvPVX(sv);
3244 }
3245 else
3246 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3247 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3248 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3249 SAVECOPLINE(&PL_compiling);
57843af0 3250 CopLINE_set(&PL_compiling, 1);
55497cff 3251 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3252 deleting the eval's FILEGV from the stash before gv_check() runs
3253 (i.e. before run-time proper). To work around the coredump that
3254 ensues, we always turn GvMULTI_on for any globals that were
3255 introduced within evals. See force_ident(). GSAR 96-10-12 */
3256 safestr = savepv(tmpbuf);
3280af22 3257 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3258 SAVEHINTS();
533c011a 3259 PL_hints = PL_op->op_targ;
7766f137 3260 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3261 if (specialWARN(PL_curcop->cop_warnings))
3262 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3263 else {
3264 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3265 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3266 }
ac27b0f5
NIS		 3267 SAVESPTR(PL_compiling.cop_io);
3268 if (specialCopIO(PL_curcop->cop_io))
3269 PL_compiling.cop_io = PL_curcop->cop_io;
3270 else {
3271 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3272 SAVEFREESV(PL_compiling.cop_io);
3273 }
d819b83a
DM		 3274 /* special case: an eval '' executed within the DB package gets lexically
3275 * placed in the first non-DB CV rather than the current CV - this
3276 * allows the debugger to execute code, find lexicals etc, in the
3277 * scope of the code being debugged. Passing &seq gets find_runcv
3278 * to do the dirty work for us */
3279 runcv = find_runcv(&seq);
a0d0e21e 3280
533c011a 3281 push_return(PL_op->op_next);
6b35e009 3282 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3283 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW		 3284
3285 /* prepare to compile string */
3286
3280af22 3287 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3288 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3289 PUTBACK;
d819b83a 3290 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3291 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3292 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3293 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3294 }
1e422769 3295 return DOCATCH(ret);
a0d0e21e
LW		 3296}
3297
3298PP(pp_leaveeval)
3299{
39644a26 3300 dSP;
a0d0e21e
LW		 3301 register SV **mark;
3302 SV **newsp;
3303 PMOP *newpm;
3304 I32 gimme;
c09156bb 3305 register PERL_CONTEXT *cx;
a0d0e21e 3306 OP *retop;
533c011a 3307 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3308 I32 optype;
3309
3310 POPBLOCK(cx,newpm);
3311 POPEVAL(cx);
3312 retop = pop_return();
3313
a1f49e72 3314 TAINT_NOT;
54310121 3315 if (gimme == G_VOID)
3316 MARK = newsp;
3317 else if (gimme == G_SCALAR) {
3318 MARK = newsp + 1;
3319 if (MARK <= SP) {
3320 if (SvFLAGS(TOPs) & SVs_TEMP)
3321 *MARK = TOPs;
3322 else
3323 *MARK = sv_mortalcopy(TOPs);
3324 }
a0d0e21e 3325 else {
54310121 3326 MEXTEND(mark,0);
3280af22 3327 *MARK = &PL_sv_undef;
a0d0e21e 3328 }
a7ec2b44 3329 SP = MARK;
a0d0e21e
LW		 3330 }
3331 else {
a1f49e72
CS		 3332 /* in case LEAVE wipes old return values */
3333 for (mark = newsp + 1; mark <= SP; mark++) {
3334 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3335 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3336 TAINT_NOT; /* Each item is independent */
3337 }
3338 }
a0d0e21e 3339 }
3280af22 3340 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3341
4fdae800 3342#ifdef DEBUGGING
3280af22 3343 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3344#endif
3280af22 3345 CvDEPTH(PL_compcv) = 0;
f46d017c 3346 lex_end();
4fdae800 3347
1ce6579f 3348 if (optype == OP_REQUIRE &&
924508f0 3349 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3350 {
1ce6579f 3351 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 3352 SV *nsv = cx->blk_eval.old_namesv;
3353 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 3354 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
f46d017c
GS		 3355 /* die_where() did LEAVE, or we won't be here */
3356 }
3357 else {
3358 LEAVE;
3359 if (!(save_flags & OPf_SPECIAL))
3360 sv_setpv(ERRSV,"");
a0d0e21e 3361 }
a0d0e21e
LW		 3362
3363 RETURNOP(retop);
3364}
3365
a0d0e21e
LW		 3366PP(pp_entertry)
3367{
39644a26 3368 dSP;
c09156bb 3369 register PERL_CONTEXT *cx;
54310121 3370 I32 gimme = GIMME_V;
a0d0e21e
LW		 3371
3372 ENTER;
3373 SAVETMPS;
3374
3375 push_return(cLOGOP->op_other->op_next);
1d76a5c3 3376 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
a0d0e21e 3377 PUSHEVAL(cx, 0, 0);
a0d0e21e 3378
faef0170 3379 PL_in_eval = EVAL_INEVAL;
38a03e6e 3380 sv_setpv(ERRSV,"");
1e422769 3381 PUTBACK;
533c011a 3382 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3383}
3384
3385PP(pp_leavetry)
3386{
39644a26 3387 dSP;
a0d0e21e
LW		 3388 register SV **mark;
3389 SV **newsp;
3390 PMOP *newpm;
8bffa5f8 3391 OP* retop;
a0d0e21e 3392 I32 gimme;
c09156bb 3393 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3394 I32 optype;
3395
3396 POPBLOCK(cx,newpm);
3397 POPEVAL(cx);
8bffa5f8 3398 retop = pop_return();
a0d0e21e 3399
a1f49e72 3400 TAINT_NOT;
54310121 3401 if (gimme == G_VOID)
3402 SP = newsp;
3403 else if (gimme == G_SCALAR) {
3404 MARK = newsp + 1;
3405 if (MARK <= SP) {
3406 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3407 *MARK = TOPs;
3408 else
3409 *MARK = sv_mortalcopy(TOPs);
3410 }
a0d0e21e 3411 else {
54310121 3412 MEXTEND(mark,0);
3280af22 3413 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3414 }
3415 SP = MARK;
3416 }
3417 else {
a1f49e72
CS		 3418 /* in case LEAVE wipes old return values */
3419 for (mark = newsp + 1; mark <= SP; mark++) {
3420 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3421 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3422 TAINT_NOT; /* Each item is independent */
3423 }
3424 }
a0d0e21e 3425 }
3280af22 3426 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3427
3428 LEAVE;
38a03e6e 3429 sv_setpv(ERRSV,"");
8bffa5f8 3430 RETURNOP(retop);
a0d0e21e
LW		 3431}
3432
0824fdcb 3433STATIC void
cea2e8a9 3434S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3435{
3436 STRLEN len;
3437 register char *s = SvPV_force(sv, len);
3438 register char *send = s + len;
9c5ffd7c 3439 register char *base = Nullch;
a0d0e21e 3440 register I32 skipspaces = 0;
9c5ffd7c
JH		 3441 bool noblank = FALSE;
3442 bool repeat = FALSE;
a0d0e21e
LW		 3443 bool postspace = FALSE;
3444 U16 *fops;
3445 register U16 *fpc;
9c5ffd7c 3446 U16 *linepc = 0;
a0d0e21e
LW		 3447 register I32 arg;
3448 bool ischop;
3449
55497cff 3450 if (len == 0)
cea2e8a9 3451 Perl_croak(aTHX_ "Null picture in formline");
ac27b0f5 3452
55497cff 3453 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3454 fpc = fops;
3455
3456 if (s < send) {
3457 linepc = fpc;
3458 *fpc++ = FF_LINEMARK;
3459 noblank = repeat = FALSE;
3460 base = s;
3461 }
3462
3463 while (s <= send) {
3464 switch (*s++) {
3465 default:
3466 skipspaces = 0;
3467 continue;
3468
3469 case '~':
3470 if (*s == '~') {
3471 repeat = TRUE;
3472 *s = ' ';
3473 }
3474 noblank = TRUE;
3475 s[-1] = ' ';
3476 /* FALL THROUGH */
3477 case ' ': case '\t':
3478 skipspaces++;
3479 continue;
ac27b0f5 3480
a0d0e21e
LW		 3481 case '\n': case 0:
3482 arg = s - base;
3483 skipspaces++;
3484 arg -= skipspaces;
3485 if (arg) {
5f05dabc 3486 if (postspace)
a0d0e21e 3487 *fpc++ = FF_SPACE;
a0d0e21e 3488 *fpc++ = FF_LITERAL;
eb160463 3489 *fpc++ = (U16)arg;
a0d0e21e 3490 }
5f05dabc 3491 postspace = FALSE;
a0d0e21e
LW		 3492 if (s <= send)
3493 skipspaces--;
3494 if (skipspaces) {
3495 *fpc++ = FF_SKIP;
eb160463 3496 *fpc++ = (U16)skipspaces;
a0d0e21e
LW		 3497 }
3498 skipspaces = 0;
3499 if (s <= send)
3500 *fpc++ = FF_NEWLINE;
3501 if (noblank) {
3502 *fpc++ = FF_BLANK;
3503 if (repeat)
3504 arg = fpc - linepc + 1;
3505 else
3506 arg = 0;
eb160463 3507 *fpc++ = (U16)arg;
a0d0e21e
LW		 3508 }
3509 if (s < send) {
3510 linepc = fpc;
3511 *fpc++ = FF_LINEMARK;
3512 noblank = repeat = FALSE;
3513 base = s;
3514 }
3515 else
3516 s++;
3517 continue;
3518
3519 case '@':
3520 case '^':
3521 ischop = s[-1] == '^';
3522
3523 if (postspace) {
3524 *fpc++ = FF_SPACE;
3525 postspace = FALSE;
3526 }
3527 arg = (s - base) - 1;
3528 if (arg) {
3529 *fpc++ = FF_LITERAL;
eb160463 3530 *fpc++ = (U16)arg;
a0d0e21e
LW		 3531 }
3532
3533 base = s - 1;
3534 *fpc++ = FF_FETCH;
3535 if (*s == '*') {
3536 s++;
3537 *fpc++ = 0;
3538 *fpc++ = FF_LINEGLOB;
3539 }
3540 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3541 arg = ischop ? 512 : 0;
3542 base = s - 1;
3543 while (*s == '#')
3544 s++;
3545 if (*s == '.') {
3546 char *f;
3547 s++;
3548 f = s;
3549 while (*s == '#')
3550 s++;
3551 arg |= 256 + (s - f);
3552 }
3553 *fpc++ = s - base; /* fieldsize for FETCH */
3554 *fpc++ = FF_DECIMAL;
eb160463 3555 *fpc++ = (U16)arg;
784707d5
JP		 3556 }
3557 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3558 arg = ischop ? 512 : 0;
3559 base = s - 1;
3560 s++; /* skip the '0' first */
3561 while (*s == '#')
3562 s++;
3563 if (*s == '.') {
3564 char *f;
3565 s++;
3566 f = s;
3567 while (*s == '#')
3568 s++;
3569 arg |= 256 + (s - f);
3570 }
3571 *fpc++ = s - base; /* fieldsize for FETCH */
3572 *fpc++ = FF_0DECIMAL;
eb160463 3573 *fpc++ = (U16)arg;
a0d0e21e
LW		 3574 }
3575 else {
3576 I32 prespace = 0;
3577 bool ismore = FALSE;
3578
3579 if (*s == '>') {
3580 while (*++s == '>') ;
3581