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