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