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