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