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