This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
vec() loses numericalness (modified version of patch suggested
[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);
8e664e10
GS
886 if (!hasargs && !is_xsub) {
887 if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
888 SAVESPTR(PL_firstgv);
889 SAVESPTR(PL_secondgv);
890 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
891 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
892 PL_sortstash = stash;
893 }
894 SAVESPTR(GvSV(PL_firstgv));
895 SAVESPTR(GvSV(PL_secondgv));
a0d0e21e
LW
896 }
897
3280af22 898 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
533c011a 899 if (!(PL_op->op_flags & OPf_SPECIAL)) {
b3933176
CS
900 cx->cx_type = CXt_SUB;
901 cx->blk_gimme = G_SCALAR;
902 PUSHSUB(cx);
903 if (!CvDEPTH(cv))
3e3baf6d 904 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
b3933176 905 }
3280af22 906 PL_sortcxix = cxstack_ix;
43481408
GS
907
908 if (hasargs && !is_xsub) {
909 /* This is mostly copied from pp_entersub */
910 AV *av = (AV*)PL_curpad[0];
911
912#ifndef USE_THREADS
913 cx->blk_sub.savearray = GvAV(PL_defgv);
914 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
915#endif /* USE_THREADS */
916 cx->blk_sub.argarray = av;
917 }
918 qsortsv((myorigmark+1), max,
919 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
a0d0e21e 920
3280af22 921 POPBLOCK(cx,PL_curpm);
ebafeae7 922 PL_stack_sp = newsp;
d3acc0f7 923 POPSTACK;
54310121 924 CATCH_SET(oldcatch);
a0d0e21e 925 }
a0d0e21e
LW
926 }
927 else {
928 if (max > 1) {
929 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
745d3a65 930 qsortsv(ORIGMARK+1, max,
9c007264
JH
931 (PL_op->op_private & OPpSORT_NUMERIC)
932 ? ( (PL_op->op_private & OPpSORT_INTEGER)
0b94c7bb
GS
933 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
934 : ( overloading ? amagic_ncmp : sv_ncmp))
9c007264
JH
935 : ( (PL_op->op_private & OPpLOCALE)
936 ? ( overloading
0b94c7bb
GS
937 ? amagic_cmp_locale
938 : sv_cmp_locale_static)
939 : ( overloading ? amagic_cmp : sv_cmp_static)));
9c007264
JH
940 if (PL_op->op_private & OPpSORT_REVERSE) {
941 SV **p = ORIGMARK+1;
942 SV **q = ORIGMARK+max;
943 while (p < q) {
944 SV *tmp = *p;
945 *p++ = *q;
946 *q-- = tmp;
947 }
948 }
a0d0e21e
LW
949 }
950 }
d0abe6c5 951 LEAVE;
3280af22 952 PL_stack_sp = ORIGMARK + max;
a0d0e21e
LW
953 return nextop;
954}
955
956/* Range stuff. */
957
958PP(pp_range)
959{
960 if (GIMME == G_ARRAY)
1a67a97c 961 return NORMAL;
538573f7 962 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 963 return cLOGOP->op_other;
538573f7 964 else
1a67a97c 965 return NORMAL;
a0d0e21e
LW
966}
967
968PP(pp_flip)
969{
4e35701f 970 djSP;
a0d0e21e
LW
971
972 if (GIMME == G_ARRAY) {
1a67a97c 973 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW
974 }
975 else {
976 dTOPss;
533c011a 977 SV *targ = PAD_SV(PL_op->op_targ);
a0d0e21e 978
533c011a 979 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 980 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW
981 : SvTRUE(sv) ) {
982 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 983 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 984 sv_setiv(targ, 1);
3e3baf6d 985 SETs(targ);
a0d0e21e
LW
986 RETURN;
987 }
988 else {
989 sv_setiv(targ, 0);
924508f0 990 SP--;
1a67a97c 991 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW
992 }
993 }
994 sv_setpv(TARG, "");
995 SETs(targ);
996 RETURN;
997 }
998}
999
1000PP(pp_flop)
1001{
4e35701f 1002 djSP;
a0d0e21e
LW
1003
1004 if (GIMME == G_ARRAY) {
1005 dPOPPOPssrl;
c1ab3db2 1006 register I32 i, j;
a0d0e21e
LW
1007 register SV *sv;
1008 I32 max;
86cb7173
HS
1009
1010 if (SvGMAGICAL(left))
1011 mg_get(left);
1012 if (SvGMAGICAL(right))
1013 mg_get(right);
a0d0e21e 1014
4633a7c4 1015 if (SvNIOKp(left) || !SvPOKp(left) ||
39eb4040
GS
1016 SvNIOKp(right) || !SvPOKp(right) ||
1017 (looks_like_number(left) && *SvPVX(left) != '0' &&
1018 looks_like_number(right) && *SvPVX(right) != '0'))
bbce6d69 1019 {
c1ab3db2 1020 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
d470f89e 1021 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW
1022 i = SvIV(left);
1023 max = SvIV(right);
bbce6d69 1024 if (max >= i) {
c1ab3db2
AK
1025 j = max - i + 1;
1026 EXTEND_MORTAL(j);
1027 EXTEND(SP, j);
bbce6d69 1028 }
c1ab3db2
AK
1029 else
1030 j = 0;
1031 while (j--) {
bbce6d69 1032 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW
1033 PUSHs(sv);
1034 }
1035 }
1036 else {
1037 SV *final = sv_mortalcopy(right);
2d8e6c8d 1038 STRLEN len, n_a;
a0d0e21e
LW
1039 char *tmps = SvPV(final, len);
1040
1041 sv = sv_mortalcopy(left);
2d8e6c8d 1042 SvPV_force(sv,n_a);
89ea2908 1043 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1044 XPUSHs(sv);
89ea2908
GA
1045 if (strEQ(SvPVX(sv),tmps))
1046 break;
a0d0e21e
LW
1047 sv = sv_2mortal(newSVsv(sv));
1048 sv_inc(sv);
1049 }
a0d0e21e
LW
1050 }
1051 }
1052 else {
1053 dTOPss;
1054 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1055 sv_inc(targ);
533c011a 1056 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1057 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW
1058 : SvTRUE(sv) ) {
1059 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1060 sv_catpv(targ, "E0");
1061 }
1062 SETs(targ);
1063 }
1064
1065 RETURN;
1066}
1067
1068/* Control. */
1069
76e3520e 1070STATIC I32
cea2e8a9 1071S_dopoptolabel(pTHX_ char *label)
a0d0e21e 1072{
11343788 1073 dTHR;
a0d0e21e 1074 register I32 i;
c09156bb 1075 register PERL_CONTEXT *cx;
a0d0e21e
LW
1076
1077 for (i = cxstack_ix; i >= 0; i--) {
1078 cx = &cxstack[i];
6b35e009 1079 switch (CxTYPE(cx)) {
a0d0e21e 1080 case CXt_SUBST:
e476b1b5
GS
1081 if (ckWARN(WARN_EXITING))
1082 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
22c35a8c 1083 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1084 break;
1085 case CXt_SUB:
e476b1b5
GS
1086 if (ckWARN(WARN_EXITING))
1087 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
22c35a8c 1088 PL_op_name[PL_op->op_type]);
a0d0e21e 1089 break;
7766f137 1090 case CXt_FORMAT:
e476b1b5
GS
1091 if (ckWARN(WARN_EXITING))
1092 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
7766f137
GS
1093 PL_op_name[PL_op->op_type]);
1094 break;
a0d0e21e 1095 case CXt_EVAL:
e476b1b5
GS
1096 if (ckWARN(WARN_EXITING))
1097 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
22c35a8c 1098 PL_op_name[PL_op->op_type]);
a0d0e21e 1099 break;
0a753a76 1100 case CXt_NULL:
e476b1b5
GS
1101 if (ckWARN(WARN_EXITING))
1102 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
22c35a8c 1103 PL_op_name[PL_op->op_type]);
0a753a76 1104 return -1;
a0d0e21e
LW
1105 case CXt_LOOP:
1106 if (!cx->blk_loop.label ||
1107 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1108 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1109 (long)i, cx->blk_loop.label));
a0d0e21e
LW
1110 continue;
1111 }
cea2e8a9 1112 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW
1113 return i;
1114 }
1115 }
1116 return i;
1117}
1118
e50aee73 1119I32
864dbfa3 1120Perl_dowantarray(pTHX)
e50aee73 1121{
54310121
PP
1122 I32 gimme = block_gimme();
1123 return (gimme == G_VOID) ? G_SCALAR : gimme;
1124}
1125
1126I32
864dbfa3 1127Perl_block_gimme(pTHX)
54310121 1128{
11343788 1129 dTHR;
e50aee73
AD
1130 I32 cxix;
1131
1132 cxix = dopoptosub(cxstack_ix);
1133 if (cxix < 0)
46fc3d4c 1134 return G_VOID;
e50aee73 1135
54310121 1136 switch (cxstack[cxix].blk_gimme) {
d2719217
GS
1137 case G_VOID:
1138 return G_VOID;
54310121 1139 case G_SCALAR:
e50aee73 1140 return G_SCALAR;
54310121
PP
1141 case G_ARRAY:
1142 return G_ARRAY;
1143 default:
cea2e8a9 1144 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS
1145 /* NOTREACHED */
1146 return 0;
54310121 1147 }
e50aee73
AD
1148}
1149
76e3520e 1150STATIC I32
cea2e8a9 1151S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1152{
11343788 1153 dTHR;
2c375eb9
GS
1154 return dopoptosub_at(cxstack, startingblock);
1155}
1156
1157STATIC I32
cea2e8a9 1158S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9
GS
1159{
1160 dTHR;
a0d0e21e 1161 I32 i;
c09156bb 1162 register PERL_CONTEXT *cx;
a0d0e21e 1163 for (i = startingblock; i >= 0; i--) {
2c375eb9 1164 cx = &cxstk[i];
6b35e009 1165 switch (CxTYPE(cx)) {
a0d0e21e
LW
1166 default:
1167 continue;
1168 case CXt_EVAL:
1169 case CXt_SUB:
7766f137 1170 case CXt_FORMAT:
cea2e8a9 1171 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW
1172 return i;
1173 }
1174 }
1175 return i;
1176}
1177
76e3520e 1178STATIC I32
cea2e8a9 1179S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1180{
11343788 1181 dTHR;
a0d0e21e 1182 I32 i;
c09156bb 1183 register PERL_CONTEXT *cx;
a0d0e21e
LW
1184 for (i = startingblock; i >= 0; i--) {
1185 cx = &cxstack[i];
6b35e009 1186 switch (CxTYPE(cx)) {
a0d0e21e
LW
1187 default:
1188 continue;
1189 case CXt_EVAL:
cea2e8a9 1190 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW
1191 return i;
1192 }
1193 }
1194 return i;
1195}
1196
76e3520e 1197STATIC I32
cea2e8a9 1198S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1199{
11343788 1200 dTHR;
a0d0e21e 1201 I32 i;
c09156bb 1202 register PERL_CONTEXT *cx;
a0d0e21e
LW
1203 for (i = startingblock; i >= 0; i--) {
1204 cx = &cxstack[i];
6b35e009 1205 switch (CxTYPE(cx)) {
a0d0e21e 1206 case CXt_SUBST:
e476b1b5
GS
1207 if (ckWARN(WARN_EXITING))
1208 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
22c35a8c 1209 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1210 break;
1211 case CXt_SUB:
e476b1b5
GS
1212 if (ckWARN(WARN_EXITING))
1213 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
22c35a8c 1214 PL_op_name[PL_op->op_type]);
a0d0e21e 1215 break;
7766f137 1216 case CXt_FORMAT:
e476b1b5
GS
1217 if (ckWARN(WARN_EXITING))
1218 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
7766f137
GS
1219 PL_op_name[PL_op->op_type]);
1220 break;
a0d0e21e 1221 case CXt_EVAL:
e476b1b5
GS
1222 if (ckWARN(WARN_EXITING))
1223 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
22c35a8c 1224 PL_op_name[PL_op->op_type]);
a0d0e21e 1225 break;
0a753a76 1226 case CXt_NULL:
e476b1b5
GS
1227 if (ckWARN(WARN_EXITING))
1228 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
22c35a8c 1229 PL_op_name[PL_op->op_type]);
0a753a76 1230 return -1;
a0d0e21e 1231 case CXt_LOOP:
cea2e8a9 1232 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW
1233 return i;
1234 }
1235 }
1236 return i;
1237}
1238
1239void
864dbfa3 1240Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1241{
11343788 1242 dTHR;
c09156bb 1243 register PERL_CONTEXT *cx;
a0d0e21e
LW
1244 I32 optype;
1245
1246 while (cxstack_ix > cxix) {
b0d9ce38 1247 SV *sv;
c90c0ff4
PP
1248 cx = &cxstack[cxstack_ix];
1249 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1250 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1251 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1252 switch (CxTYPE(cx)) {
c90c0ff4
PP
1253 case CXt_SUBST:
1254 POPSUBST(cx);
1255 continue; /* not break */
a0d0e21e 1256 case CXt_SUB:
b0d9ce38
GS
1257 POPSUB(cx,sv);
1258 LEAVESUB(sv);
a0d0e21e
LW
1259 break;
1260 case CXt_EVAL:
1261 POPEVAL(cx);
1262 break;
1263 case CXt_LOOP:
1264 POPLOOP(cx);
1265 break;
0a753a76 1266 case CXt_NULL:
a0d0e21e 1267 break;
7766f137
GS
1268 case CXt_FORMAT:
1269 POPFORMAT(cx);
1270 break;
a0d0e21e 1271 }
c90c0ff4 1272 cxstack_ix--;
a0d0e21e
LW
1273 }
1274}
1275
067f92a0
GS
1276/*
1277 * Closures mentioned at top level of eval cannot be referenced
1278 * again, and their presence indirectly causes a memory leak.
1279 * (Note that the fact that compcv and friends are still set here
1280 * is, AFAIK, an accident.) --Chip
1281 *
1282 * XXX need to get comppad et al from eval's cv rather than
1283 * relying on the incidental global values.
1284 */
1285STATIC void
cea2e8a9 1286S_free_closures(pTHX)
067f92a0
GS
1287{
1288 dTHR;
1289 SV **svp = AvARRAY(PL_comppad_name);
1290 I32 ix;
1291 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1292 SV *sv = svp[ix];
1293 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1294 SvREFCNT_dec(sv);
1295 svp[ix] = &PL_sv_undef;
1296
1297 sv = PL_curpad[ix];
1298 if (CvCLONE(sv)) {
1299 SvREFCNT_dec(CvOUTSIDE(sv));
1300 CvOUTSIDE(sv) = Nullcv;
1301 }
1302 else {
1303 SvREFCNT_dec(sv);
1304 sv = NEWSV(0,0);
1305 SvPADTMP_on(sv);
1306 PL_curpad[ix] = sv;
1307 }
1308 }
1309 }
1310}
1311
5a844595
GS
1312void
1313Perl_qerror(pTHX_ SV *err)
1314{
1315 if (PL_in_eval)
1316 sv_catsv(ERRSV, err);
1317 else if (PL_errors)
1318 sv_catsv(PL_errors, err);
1319 else
894356b3 1320 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS
1321 ++PL_error_count;
1322}
1323
a0d0e21e 1324OP *
864dbfa3 1325Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1326{
2d8e6c8d 1327 STRLEN n_a;
3280af22 1328 if (PL_in_eval) {
a0d0e21e 1329 I32 cxix;
c09156bb 1330 register PERL_CONTEXT *cx;
a0d0e21e
LW
1331 I32 gimme;
1332 SV **newsp;
1333
4e6ea2c3 1334 if (message) {
faef0170 1335 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS
1336 static char prefix[] = "\t(in cleanup) ";
1337 SV *err = ERRSV;
1338 char *e = Nullch;
1339 if (!SvPOK(err))
1340 sv_setpv(err,"");
1341 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1342 e = SvPV(err, n_a);
1343 e += n_a - msglen;
1344 if (*e != *message || strNE(e,message))
1345 e = Nullch;
1346 }
1347 if (!e) {
1348 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1349 sv_catpvn(err, prefix, sizeof(prefix)-1);
1350 sv_catpvn(err, message, msglen);
e476b1b5 1351 if (ckWARN(WARN_MISC)) {
98eae8f5 1352 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
e476b1b5 1353 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
4e6ea2c3 1354 }
4633a7c4 1355 }
4633a7c4 1356 }
4e6ea2c3 1357 else
06bf62c7 1358 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW
1359 }
1360 else
06bf62c7 1361 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1362
5a844595
GS
1363 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1364 && PL_curstackinfo->si_prev)
1365 {
bac4b2ad 1366 dounwind(-1);
d3acc0f7 1367 POPSTACK;
bac4b2ad 1368 }
e336de0d 1369
a0d0e21e
LW
1370 if (cxix >= 0) {
1371 I32 optype;
1372
1373 if (cxix < cxstack_ix)
1374 dounwind(cxix);
1375
3280af22 1376 POPBLOCK(cx,PL_curpm);
6b35e009 1377 if (CxTYPE(cx) != CXt_EVAL) {
bf49b057
GS
1378 PerlIO_write(Perl_error_log, "panic: die ", 11);
1379 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW
1380 my_exit(1);
1381 }
1382 POPEVAL(cx);
1383
1384 if (gimme == G_SCALAR)
3280af22
NIS
1385 *++newsp = &PL_sv_undef;
1386 PL_stack_sp = newsp;
a0d0e21e
LW
1387
1388 LEAVE;
748a9306 1389
7a2e2cd6 1390 if (optype == OP_REQUIRE) {
2d8e6c8d 1391 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS
1392 DIE(aTHX_ "%sCompilation failed in require",
1393 *msg ? msg : "Unknown error\n");
7a2e2cd6 1394 }
a0d0e21e
LW
1395 return pop_return();
1396 }
1397 }
9cc2fdd3 1398 if (!message)
06bf62c7 1399 message = SvPVx(ERRSV, msglen);
d175a3f0
GS
1400 {
1401#ifdef USE_SFIO
1402 /* SFIO can really mess with your errno */
1403 int e = errno;
1404#endif
bf49b057
GS
1405 PerlIO *serr = Perl_error_log;
1406
1407 PerlIO_write(serr, message, msglen);
1408 (void)PerlIO_flush(serr);
d175a3f0
GS
1409#ifdef USE_SFIO
1410 errno = e;
1411#endif
1412 }
f86702cc
PP
1413 my_failure_exit();
1414 /* NOTREACHED */
a0d0e21e
LW
1415 return 0;
1416}
1417
1418PP(pp_xor)
1419{
4e35701f 1420 djSP; dPOPTOPssrl;
a0d0e21e
LW
1421 if (SvTRUE(left) != SvTRUE(right))
1422 RETSETYES;
1423 else
1424 RETSETNO;
1425}
1426
1427PP(pp_andassign)
1428{
4e35701f 1429 djSP;
a0d0e21e
LW
1430 if (!SvTRUE(TOPs))
1431 RETURN;
1432 else
1433 RETURNOP(cLOGOP->op_other);
1434}
1435
1436PP(pp_orassign)
1437{
4e35701f 1438 djSP;
a0d0e21e
LW
1439 if (SvTRUE(TOPs))
1440 RETURN;
1441 else
1442 RETURNOP(cLOGOP->op_other);
1443}
1444
a0d0e21e
LW
1445PP(pp_caller)
1446{
4e35701f 1447 djSP;
a0d0e21e 1448 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1449 register PERL_CONTEXT *cx;
2c375eb9 1450 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1451 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1452 I32 dbcxix;
54310121 1453 I32 gimme;
ed094faf 1454 char *stashname;
a0d0e21e
LW
1455 SV *sv;
1456 I32 count = 0;
1457
1458 if (MAXARG)
1459 count = POPi;
e476b1b5 1460 EXTEND(SP, 10);
a0d0e21e 1461 for (;;) {
2c375eb9
GS
1462 /* we may be in a higher stacklevel, so dig down deeper */
1463 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1464 top_si = top_si->si_prev;
1465 ccstack = top_si->si_cxstack;
1466 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1467 }
a0d0e21e
LW
1468 if (cxix < 0) {
1469 if (GIMME != G_ARRAY)
1470 RETPUSHUNDEF;
1471 RETURN;
1472 }
3280af22
NIS
1473 if (PL_DBsub && cxix >= 0 &&
1474 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1475 count++;
1476 if (!count--)
1477 break;
2c375eb9 1478 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1479 }
2c375eb9
GS
1480
1481 cx = &ccstack[cxix];
7766f137 1482 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2c375eb9
GS
1483 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1484 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1485 field below is defined for any cx. */
3280af22 1486 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1487 cx = &ccstack[dbcxix];
06a5b730
PP
1488 }
1489
ed094faf 1490 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1491 if (GIMME != G_ARRAY) {
ed094faf 1492 if (!stashname)
3280af22 1493 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1494 else {
1495 dTARGET;
ed094faf 1496 sv_setpv(TARG, stashname);
49d8d3a1
MB
1497 PUSHs(TARG);
1498 }
a0d0e21e
LW
1499 RETURN;
1500 }
a0d0e21e 1501
ed094faf 1502 if (!stashname)
3280af22 1503 PUSHs(&PL_sv_undef);
49d8d3a1 1504 else
ed094faf
GS
1505 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1506 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
57843af0 1507 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW
1508 if (!MAXARG)
1509 RETURN;
7766f137
GS
1510 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1511 /* So is ccstack[dbcxix]. */
a0d0e21e 1512 sv = NEWSV(49, 0);
2c375eb9 1513 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW
1514 PUSHs(sv_2mortal(sv));
1515 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1516 }
1517 else {
79cb57f6 1518 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW
1519 PUSHs(sv_2mortal(newSViv(0)));
1520 }
54310121
PP
1521 gimme = (I32)cx->blk_gimme;
1522 if (gimme == G_VOID)
3280af22 1523 PUSHs(&PL_sv_undef);
54310121
PP
1524 else
1525 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1526 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1527 /* eval STRING */
06a5b730 1528 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1529 PUSHs(cx->blk_eval.cur_text);
3280af22 1530 PUSHs(&PL_sv_no);
0f79a09d 1531 }
811a4de9 1532 /* require */
0f79a09d
GS
1533 else if (cx->blk_eval.old_namesv) {
1534 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1535 PUSHs(&PL_sv_yes);
06a5b730 1536 }
811a4de9
GS
1537 /* eval BLOCK (try blocks have old_namesv == 0) */
1538 else {
1539 PUSHs(&PL_sv_undef);
1540 PUSHs(&PL_sv_undef);
1541 }
4633a7c4 1542 }
a682de96
GS
1543 else {
1544 PUSHs(&PL_sv_undef);
1545 PUSHs(&PL_sv_undef);
1546 }
1547 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1548 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1549 {
a0d0e21e
LW
1550 AV *ary = cx->blk_sub.argarray;
1551 int off = AvARRAY(ary) - AvALLOC(ary);
1552
3280af22 1553 if (!PL_dbargs) {
a0d0e21e 1554 GV* tmpgv;
3280af22 1555 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1556 SVt_PVAV)));
a5f75d66 1557 GvMULTI_on(tmpgv);
3280af22 1558 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW
1559 }
1560
3280af22
NIS
1561 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1562 av_extend(PL_dbargs, AvFILLp(ary) + off);
1563 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1564 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1565 }
f3aa04c2
GS
1566 /* XXX only hints propagated via op_private are currently
1567 * visible (others are not easily accessible, since they
1568 * use the global PL_hints) */
1569 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1570 HINT_PRIVATE_MASK)));
e476b1b5
GS
1571 {
1572 SV * mask ;
1573 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
114bafba
GS
1574
1575 if (old_warnings == pWARN_NONE ||
1576 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
e476b1b5 1577 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
114bafba
GS
1578 else if (old_warnings == pWARN_ALL ||
1579 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
e476b1b5
GS
1580 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1581 else
1582 mask = newSVsv(old_warnings);
1583 PUSHs(sv_2mortal(mask));
1584 }
a0d0e21e
LW
1585 RETURN;
1586}
1587
a0d0e21e
LW
1588PP(pp_reset)
1589{
4e35701f 1590 djSP;
a0d0e21e 1591 char *tmps;
2d8e6c8d 1592 STRLEN n_a;
a0d0e21e
LW
1593
1594 if (MAXARG < 1)
1595 tmps = "";
1596 else
2d8e6c8d 1597 tmps = POPpx;
11faa288 1598 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1599 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1600 RETURN;
1601}
1602
1603PP(pp_lineseq)
1604{
1605 return NORMAL;
1606}
1607
1608PP(pp_dbstate)
1609{
533c011a 1610 PL_curcop = (COP*)PL_op;
a0d0e21e 1611 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1612 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1613 FREETMPS;
1614
533c011a 1615 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1616 {
924508f0 1617 djSP;
a0d0e21e 1618 register CV *cv;
c09156bb 1619 register PERL_CONTEXT *cx;
748a9306 1620 I32 gimme = G_ARRAY;
a0d0e21e
LW
1621 I32 hasargs;
1622 GV *gv;
1623
3280af22 1624 gv = PL_DBgv;
a0d0e21e 1625 cv = GvCV(gv);
a0d0e21e 1626 if (!cv)
cea2e8a9 1627 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1628
3280af22 1629 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1630 return NORMAL;
748a9306 1631
4633a7c4
LW
1632 ENTER;
1633 SAVETMPS;
1634
3280af22 1635 SAVEI32(PL_debug);
55497cff 1636 SAVESTACK_POS();
3280af22 1637 PL_debug = 0;
748a9306 1638 hasargs = 0;
924508f0 1639 SPAGAIN;
748a9306 1640
533c011a 1641 push_return(PL_op->op_next);
924508f0 1642 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW
1643 PUSHSUB(cx);
1644 CvDEPTH(cv)++;
1645 (void)SvREFCNT_inc(cv);
7766f137 1646 SAVEVPTR(PL_curpad);
3280af22 1647 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW
1648 RETURNOP(CvSTART(cv));
1649 }
1650 else
1651 return NORMAL;
1652}
1653
1654PP(pp_scope)
1655{
1656 return NORMAL;
1657}
1658
1659PP(pp_enteriter)
1660{
4e35701f 1661 djSP; dMARK;
c09156bb 1662 register PERL_CONTEXT *cx;
54310121 1663 I32 gimme = GIMME_V;
a0d0e21e 1664 SV **svp;
7766f137
GS
1665 U32 cxtype = CXt_LOOP;
1666#ifdef USE_ITHREADS
1667 void *iterdata;
1668#endif
a0d0e21e 1669
4633a7c4
LW
1670 ENTER;
1671 SAVETMPS;
1672
54b9620d 1673#ifdef USE_THREADS
0214ae40
GS
1674 if (PL_op->op_flags & OPf_SPECIAL) {
1675 dTHR;
1676 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1677 SAVEGENERICSV(*svp);
1678 *svp = NEWSV(0,0);
1679 }
a0d0e21e 1680 else
54b9620d 1681#endif /* USE_THREADS */
533c011a
NIS
1682 if (PL_op->op_targ) {
1683 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d 1684 SAVESPTR(*svp);
7766f137
GS
1685#ifdef USE_ITHREADS
1686 iterdata = (void*)PL_op->op_targ;
1687 cxtype |= CXp_PADVAR;
1688#endif
54b9620d
MB
1689 }
1690 else {
7766f137
GS
1691 GV *gv = (GV*)POPs;
1692 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS
1693 SAVEGENERICSV(*svp);
1694 *svp = NEWSV(0,0);
7766f137
GS
1695#ifdef USE_ITHREADS
1696 iterdata = (void*)gv;
1697#endif
54b9620d 1698 }
4633a7c4 1699
a0d0e21e
LW
1700 ENTER;
1701
7766f137
GS
1702 PUSHBLOCK(cx, cxtype, SP);
1703#ifdef USE_ITHREADS
1704 PUSHLOOP(cx, iterdata, MARK);
1705#else
a0d0e21e 1706 PUSHLOOP(cx, svp, MARK);
7766f137 1707#endif
533c011a 1708 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1709 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA
1710 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1711 dPOPss;
1712 if (SvNIOKp(sv) || !SvPOKp(sv) ||
39eb4040
GS
1713 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1714 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1715 looks_like_number((SV*)cx->blk_loop.iterary) &&
1716 *SvPVX(cx->blk_loop.iterary) != '0'))
1717 {
89ea2908
GA
1718 if (SvNV(sv) < IV_MIN ||
1719 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
d470f89e 1720 DIE(aTHX_ "Range iterator outside integer range");
89ea2908
GA
1721 cx->blk_loop.iterix = SvIV(sv);
1722 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1723 }
1724 else
1725 cx->blk_loop.iterlval = newSVsv(sv);
1726 }
1727 }
4633a7c4 1728 else {
3280af22
NIS
1729 cx->blk_loop.iterary = PL_curstack;
1730 AvFILLp(PL_curstack) = SP - PL_stack_base;
1731 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1732 }
a0d0e21e
LW
1733
1734 RETURN;
1735}
1736
1737PP(pp_enterloop)
1738{
4e35701f 1739 djSP;
c09156bb 1740 register PERL_CONTEXT *cx;
54310121 1741 I32 gimme = GIMME_V;
a0d0e21e
LW
1742
1743 ENTER;
1744 SAVETMPS;
1745 ENTER;
1746
1747 PUSHBLOCK(cx, CXt_LOOP, SP);
1748 PUSHLOOP(cx, 0, SP);
1749
1750 RETURN;
1751}
1752
1753PP(pp_leaveloop)
1754{
4e35701f 1755 djSP;
c09156bb 1756 register PERL_CONTEXT *cx;
a0d0e21e
LW
1757 I32 gimme;
1758 SV **newsp;
1759 PMOP *newpm;
1760 SV **mark;
1761
1762 POPBLOCK(cx,newpm);
4fdae800 1763 mark = newsp;
a8bba7fa 1764 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1765
a1f49e72 1766 TAINT_NOT;
54310121
PP
1767 if (gimme == G_VOID)
1768 ; /* do nothing */
1769 else if (gimme == G_SCALAR) {
1770 if (mark < SP)
1771 *++newsp = sv_mortalcopy(*SP);
1772 else
3280af22 1773 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1774 }
1775 else {
a1f49e72 1776 while (mark < SP) {
a0d0e21e 1777 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1778 TAINT_NOT; /* Each item is independent */
1779 }
a0d0e21e 1780 }
f86702cc
PP
1781 SP = newsp;
1782 PUTBACK;
1783
a8bba7fa 1784 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1785 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1786
a0d0e21e
LW
1787 LEAVE;
1788 LEAVE;
1789
f86702cc 1790 return NORMAL;
a0d0e21e
LW
1791}
1792
1793PP(pp_return)
1794{
4e35701f 1795 djSP; dMARK;
a0d0e21e 1796 I32 cxix;
c09156bb 1797 register PERL_CONTEXT *cx;
f86702cc 1798 bool popsub2 = FALSE;
b45de488 1799 bool clear_errsv = FALSE;
a0d0e21e
LW
1800 I32 gimme;
1801 SV **newsp;
1802 PMOP *newpm;
1803 I32 optype = 0;
b0d9ce38 1804 SV *sv;
a0d0e21e 1805
3280af22 1806 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS
1807 if (cxstack_ix == PL_sortcxix
1808 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1809 {
3280af22
NIS
1810 if (cxstack_ix > PL_sortcxix)
1811 dounwind(PL_sortcxix);
1812 AvARRAY(PL_curstack)[1] = *SP;
1813 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1814 return 0;
1815 }
1816 }
1817
1818 cxix = dopoptosub(cxstack_ix);
1819 if (cxix < 0)
cea2e8a9 1820 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW
1821 if (cxix < cxstack_ix)
1822 dounwind(cxix);
1823
1824 POPBLOCK(cx,newpm);
6b35e009 1825 switch (CxTYPE(cx)) {
a0d0e21e 1826 case CXt_SUB:
f86702cc 1827 popsub2 = TRUE;
a0d0e21e
LW
1828 break;
1829 case CXt_EVAL:
b45de488
GS
1830 if (!(PL_in_eval & EVAL_KEEPERR))
1831 clear_errsv = TRUE;
a0d0e21e 1832 POPEVAL(cx);
1d76a5c3
GS
1833 if (CxTRYBLOCK(cx))
1834 break;
067f92a0
GS
1835 if (AvFILLp(PL_comppad_name) >= 0)
1836 free_closures();
1837 lex_end();
748a9306
LW
1838 if (optype == OP_REQUIRE &&
1839 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1840 {
54310121 1841 /* Unassume the success we assumed earlier. */
0f79a09d
GS
1842 SV *nsv = cx->blk_eval.old_namesv;
1843 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1844 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
748a9306 1845 }
a0d0e21e 1846 break;
7766f137
GS
1847 case CXt_FORMAT:
1848 POPFORMAT(cx);
1849 break;
a0d0e21e 1850 default:
cea2e8a9 1851 DIE(aTHX_ "panic: return");
a0d0e21e
LW
1852 }
1853
a1f49e72 1854 TAINT_NOT;
a0d0e21e 1855 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1856 if (MARK < SP) {
1857 if (popsub2) {
a8bba7fa 1858 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
1859 if (SvTEMP(TOPs)) {
1860 *++newsp = SvREFCNT_inc(*SP);
1861 FREETMPS;
1862 sv_2mortal(*newsp);
959e3673
GS
1863 }
1864 else {
1865 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 1866 FREETMPS;
959e3673
GS
1867 *++newsp = sv_mortalcopy(sv);
1868 SvREFCNT_dec(sv);
a29cdaf0 1869 }
959e3673
GS
1870 }
1871 else
a29cdaf0 1872 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS
1873 }
1874 else
a29cdaf0 1875 *++newsp = sv_mortalcopy(*SP);
959e3673
GS
1876 }
1877 else
3280af22 1878 *++newsp = &PL_sv_undef;
a0d0e21e 1879 }
54310121 1880 else if (gimme == G_ARRAY) {
a1f49e72 1881 while (++MARK <= SP) {
f86702cc
PP
1882 *++newsp = (popsub2 && SvTEMP(*MARK))
1883 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1884 TAINT_NOT; /* Each item is independent */
1885 }
a0d0e21e 1886 }
3280af22 1887 PL_stack_sp = newsp;
a0d0e21e 1888
f86702cc
PP
1889 /* Stack values are safe: */
1890 if (popsub2) {
b0d9ce38 1891 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1892 }
b0d9ce38
GS
1893 else
1894 sv = Nullsv;
3280af22 1895 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1896
a0d0e21e 1897 LEAVE;
b0d9ce38 1898 LEAVESUB(sv);
b45de488
GS
1899 if (clear_errsv)
1900 sv_setpv(ERRSV,"");
a0d0e21e
LW
1901 return pop_return();
1902}
1903
1904PP(pp_last)
1905{
4e35701f 1906 djSP;
a0d0e21e 1907 I32 cxix;
c09156bb 1908 register PERL_CONTEXT *cx;
f86702cc 1909 I32 pop2 = 0;
a0d0e21e
LW
1910 I32 gimme;
1911 I32 optype;
1912 OP *nextop;
1913 SV **newsp;
1914 PMOP *newpm;
a8bba7fa 1915 SV **mark;
b0d9ce38 1916 SV *sv = Nullsv;
a0d0e21e 1917
533c011a 1918 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1919 cxix = dopoptoloop(cxstack_ix);
1920 if (cxix < 0)
a651a37d 1921 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
1922 }
1923 else {
1924 cxix = dopoptolabel(cPVOP->op_pv);
1925 if (cxix < 0)
cea2e8a9 1926 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
1927 }
1928 if (cxix < cxstack_ix)
1929 dounwind(cxix);
1930
1931 POPBLOCK(cx,newpm);
a8bba7fa 1932 mark = newsp;
6b35e009 1933 switch (CxTYPE(cx)) {
a0d0e21e 1934 case CXt_LOOP:
f86702cc 1935 pop2 = CXt_LOOP;
a8bba7fa
GS
1936 newsp = PL_stack_base + cx->blk_loop.resetsp;
1937 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1938 break;
f86702cc 1939 case CXt_SUB:
f86702cc 1940 pop2 = CXt_SUB;
a0d0e21e
LW
1941 nextop = pop_return();
1942 break;
f86702cc
PP
1943 case CXt_EVAL:
1944 POPEVAL(cx);
a0d0e21e
LW
1945 nextop = pop_return();
1946 break;
7766f137
GS
1947 case CXt_FORMAT:
1948 POPFORMAT(cx);
1949 nextop = pop_return();
1950 break;
a0d0e21e 1951 default:
cea2e8a9 1952 DIE(aTHX_ "panic: last");
a0d0e21e
LW
1953 }
1954
a1f49e72 1955 TAINT_NOT;
a0d0e21e 1956 if (gimme == G_SCALAR) {
f86702cc
PP
1957 if (MARK < SP)
1958 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1959 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1960 else
3280af22 1961 *++newsp = &PL_sv_undef;
a0d0e21e 1962 }
54310121 1963 else if (gimme == G_ARRAY) {
a1f49e72 1964 while (++MARK <= SP) {
f86702cc
PP
1965 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1966 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1967 TAINT_NOT; /* Each item is independent */
1968 }
f86702cc
PP
1969 }
1970 SP = newsp;
1971 PUTBACK;
1972
1973 /* Stack values are safe: */
1974 switch (pop2) {
1975 case CXt_LOOP:
a8bba7fa 1976 POPLOOP(cx); /* release loop vars ... */
4fdae800 1977 LEAVE;
f86702cc
PP
1978 break;
1979 case CXt_SUB:
b0d9ce38 1980 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1981 break;
a0d0e21e 1982 }
3280af22 1983 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
1984
1985 LEAVE;
b0d9ce38 1986 LEAVESUB(sv);
f86702cc 1987 return nextop;
a0d0e21e
LW
1988}
1989
1990PP(pp_next)
1991{
1992 I32 cxix;
c09156bb 1993 register PERL_CONTEXT *cx;
85538317 1994 I32 inner;
a0d0e21e 1995
533c011a 1996 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1997 cxix = dopoptoloop(cxstack_ix);
1998 if (cxix < 0)
a651a37d 1999 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
2000 }
2001 else {
2002 cxix = dopoptolabel(cPVOP->op_pv);
2003 if (cxix < 0)
cea2e8a9 2004 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
2005 }
2006 if (cxix < cxstack_ix)
2007 dounwind(cxix);
2008
85538317
GS
2009 /* clear off anything above the scope we're re-entering, but
2010 * save the rest until after a possible continue block */
2011 inner = PL_scopestack_ix;
1ba6ee2b 2012 TOPBLOCK(cx);
85538317
GS
2013 if (PL_scopestack_ix < inner)
2014 leave_scope(PL_scopestack[PL_scopestack_ix]);
1ba6ee2b 2015 return cx->blk_loop.next_op;
a0d0e21e
LW
2016}
2017
2018PP(pp_redo)
2019{
2020 I32 cxix;
c09156bb 2021 register PERL_CONTEXT *cx;
a0d0e21e
LW
2022 I32 oldsave;
2023
533c011a 2024 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2025 cxix = dopoptoloop(cxstack_ix);
2026 if (cxix < 0)
a651a37d 2027 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
2028 }
2029 else {
2030 cxix = dopoptolabel(cPVOP->op_pv);
2031 if (cxix < 0)
cea2e8a9 2032 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
2033 }
2034 if (cxix < cxstack_ix)
2035 dounwind(cxix);
2036
2037 TOPBLOCK(cx);
3280af22 2038 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2039 LEAVE_SCOPE(oldsave);
2040 return cx->blk_loop.redo_op;
2041}
2042
0824fdcb 2043STATIC OP *
cea2e8a9 2044S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW
2045{
2046 OP *kid;
2047 OP **ops = opstack;
fc36a67e 2048 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2049
fc36a67e 2050 if (ops >= oplimit)
cea2e8a9 2051 Perl_croak(aTHX_ too_deep);
11343788
MB
2052 if (o->op_type == OP_LEAVE ||
2053 o->op_type == OP_SCOPE ||
2054 o->op_type == OP_LEAVELOOP ||
2055 o->op_type == OP_LEAVETRY)
fc36a67e 2056 {
5dc0d613 2057 *ops++ = cUNOPo->op_first;
fc36a67e 2058 if (ops >= oplimit)
cea2e8a9 2059 Perl_croak(aTHX_ too_deep);
fc36a67e 2060 }
c4aa4e48 2061 *ops = 0;
11343788 2062 if (o->op_flags & OPf_KIDS) {
5c0ca799 2063 dTHR;
a0d0e21e 2064 /* First try all the kids at this level, since that's likeliest. */
11343788 2065 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS
2066 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2067 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW
2068 return kid;
2069 }
11343788 2070 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2071 if (kid == PL_lastgotoprobe)
a0d0e21e 2072 continue;
c4aa4e48
GS
2073 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2074 (ops == opstack ||
2075 (ops[-1]->op_type != OP_NEXTSTATE &&
2076 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 2077 *ops++ = kid;
155aba94 2078 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2079 return o;
a0d0e21e
LW
2080 }
2081 }
c4aa4e48 2082 *ops = 0;
a0d0e21e
LW
2083 return 0;
2084}
2085
2086PP(pp_dump)
2087{
cea2e8a9 2088 return pp_goto();
a0d0e21e
LW
2089 /*NOTREACHED*/
2090}
2091
2092PP(pp_goto)
2093{
4e35701f 2094 djSP;
a0d0e21e
LW
2095 OP *retop = 0;
2096 I32 ix;
c09156bb 2097 register PERL_CONTEXT *cx;
fc36a67e
PP
2098#define GOTO_DEPTH 64
2099 OP *enterops[GOTO_DEPTH];
a0d0e21e 2100 char *label;
533c011a 2101 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2102 static char must_have_label[] = "goto must have label";
a0d0e21e
LW
2103
2104 label = 0;
533c011a 2105 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2106 SV *sv = POPs;
2d8e6c8d 2107 STRLEN n_a;
a0d0e21e
LW
2108
2109 /* This egregious kludge implements goto &subroutine */
2110 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2111 I32 cxix;
c09156bb 2112 register PERL_CONTEXT *cx;
a0d0e21e
LW
2113 CV* cv = (CV*)SvRV(sv);
2114 SV** mark;
2115 I32 items = 0;
2116 I32 oldsave;
2117
e8f7dd13 2118 retry:
4aa0a1f7 2119 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS
2120 GV *gv = CvGV(cv);
2121 GV *autogv;
2122 if (gv) {
2123 SV *tmpstr;
2124 /* autoloaded stub? */
2125 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2126 goto retry;
2127 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2128 GvNAMELEN(gv), FALSE);
2129 if (autogv && (cv = GvCV(autogv)))
2130 goto retry;
2131 tmpstr = sv_newmortal();
2132 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2133 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2134 }
cea2e8a9 2135 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2136 }
2137
a0d0e21e
LW
2138 /* First do some returnish stuff. */
2139 cxix = dopoptosub(cxstack_ix);
2140 if (cxix < 0)
cea2e8a9 2141 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2142 if (cxix < cxstack_ix)
2143 dounwind(cxix);
2144 TOPBLOCK(cx);
6b35e009 2145 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2146 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2147 mark = PL_stack_sp;
d8b46c1b
GS
2148 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2149 /* put @_ back onto stack */
a0d0e21e
LW
2150 AV* av = cx->blk_sub.argarray;
2151
93965878 2152 items = AvFILLp(av) + 1;
3280af22
NIS
2153 PL_stack_sp++;
2154 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2155 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2156 PL_stack_sp += items;
6d4ff0d2 2157#ifndef USE_THREADS
3280af22
NIS
2158 SvREFCNT_dec(GvAV(PL_defgv));
2159 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2160#endif /* USE_THREADS */
d8b46c1b 2161 /* abandon @_ if it got reified */
62b1ebc2 2162 if (AvREAL(av)) {
d8b46c1b
GS
2163 (void)sv_2mortal((SV*)av); /* delay until return */
2164 av = newAV();
2165 av_extend(av, items-1);
2166 AvFLAGS(av) = AVf_REIFY;
2167 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2168 }
a0d0e21e 2169 }
1fa4e549
AD
2170 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2171 AV* av;
1fa4e549 2172#ifdef USE_THREADS
533c011a 2173 av = (AV*)PL_curpad[0];
1fa4e549 2174#else
3280af22 2175 av = GvAV(PL_defgv);
1fa4e549
AD
2176#endif
2177 items = AvFILLp(av) + 1;
3280af22
NIS
2178 PL_stack_sp++;
2179 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2180 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2181 PL_stack_sp += items;
1fa4e549 2182 }
6b35e009 2183 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2184 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2185 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2186 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2187 LEAVE_SCOPE(oldsave);
2188
2189 /* Now do some callish stuff. */
2190 SAVETMPS;
2191 if (CvXSUB(cv)) {
67caa1fe 2192#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2193 if (CvOLDSTYLE(cv)) {
20ce7b12 2194 I32 (*fp3)(int,int,int);
924508f0
GS
2195 while (SP > mark) {
2196 SP[1] = SP[0];
2197 SP--;
a0d0e21e 2198 }
7766f137 2199 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2200 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2201 mark - PL_stack_base + 1,
ecfc5424 2202 items);
3280af22 2203 SP = PL_stack_base + items;
a0d0e21e 2204 }
67caa1fe
GS
2205 else
2206#endif /* PERL_XSUB_OLDSTYLE */
2207 {
1fa4e549
AD
2208 SV **newsp;
2209 I32 gimme;
2210
3280af22 2211 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD
2212 /* Push a mark for the start of arglist */
2213 PUSHMARK(mark);
0cb96387 2214 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2215 /* Pop the current context like a decent sub should */
3280af22 2216 POPBLOCK(cx, PL_curpm);
1fa4e549 2217 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW
2218 }
2219 LEAVE;
2220 return pop_return();
2221 }
2222 else {
2223 AV* padlist = CvPADLIST(cv);
2224 SV** svp = AvARRAY(padlist);
6b35e009 2225 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2226 PL_in_eval = cx->blk_eval.old_in_eval;
2227 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2228 cx->cx_type = CXt_SUB;
2229 cx->blk_sub.hasargs = 0;
2230 }
a0d0e21e
LW
2231 cx->blk_sub.cv = cv;
2232 cx->blk_sub.olddepth = CvDEPTH(cv);
2233 CvDEPTH(cv)++;
2234 if (CvDEPTH(cv) < 2)
2235 (void)SvREFCNT_inc(cv);
2236 else { /* save temporaries on recursion? */
599cee73 2237 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2238 sub_crush_depth(cv);
93965878 2239 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2240 AV *newpad = newAV();
4aa0a1f7 2241 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2242 I32 ix = AvFILLp((AV*)svp[1]);
7766f137 2243 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2244 svp = AvARRAY(svp[0]);
748a9306 2245 for ( ;ix > 0; ix--) {
7766f137 2246 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2247 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2248 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2249 || *name == '&')
2250 {
2251 /* outer lexical or anon code */
748a9306 2252 av_store(newpad, ix,
4aa0a1f7 2253 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW
2254 }
2255 else { /* our own lexical */
2256 if (*name == '@')
2257 av_store(newpad, ix, sv = (SV*)newAV());
2258 else if (*name == '%')
2259 av_store(newpad, ix, sv = (SV*)newHV());
2260 else
2261 av_store(newpad, ix, sv = NEWSV(0,0));
2262 SvPADMY_on(sv);
2263 }
a0d0e21e 2264 }
7766f137 2265 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
743e66e6
GS
2266 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2267 }
a0d0e21e 2268 else {
748a9306 2269 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2270 SvPADTMP_on(sv);
2271 }
2272 }
2273 if (cx->blk_sub.hasargs) {
2274 AV* av = newAV();
2275 av_extend(av, 0);
2276 av_store(newpad, 0, (SV*)av);
2277 AvFLAGS(av) = AVf_REIFY;
2278 }
2279 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2280 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2281 svp = AvARRAY(padlist);
2282 }
2283 }
6d4ff0d2
MB
2284#ifdef USE_THREADS
2285 if (!cx->blk_sub.hasargs) {
533c011a 2286 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2287
93965878 2288 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2289 if (items) {
2290 /* Mark is at the end of the stack. */
924508f0
GS
2291 EXTEND(SP, items);
2292 Copy(AvARRAY(av), SP + 1, items, SV*);
2293 SP += items;
6d4ff0d2
MB
2294 PUTBACK ;
2295 }
2296 }
2297#endif /* USE_THREADS */
7766f137 2298 SAVEVPTR(PL_curpad);
3280af22 2299 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB
2300#ifndef USE_THREADS
2301 if (cx->blk_sub.hasargs)
2302#endif /* USE_THREADS */
2303 {
3280af22 2304 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW
2305 SV** ary;
2306
6d4ff0d2 2307#ifndef USE_THREADS
3280af22
NIS
2308 cx->blk_sub.savearray = GvAV(PL_defgv);
2309 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB
2310#endif /* USE_THREADS */
2311 cx->blk_sub.argarray = av;
a0d0e21e
LW
2312 ++mark;
2313
2314 if (items >= AvMAX(av) + 1) {
2315 ary = AvALLOC(av);
2316 if (AvARRAY(av) != ary) {
2317 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2318 SvPVX(av) = (char*)ary;
2319 }
2320 if (items >= AvMAX(av) + 1) {
2321 AvMAX(av) = items - 1;
2322 Renew(ary,items+1,SV*);
2323 AvALLOC(av) = ary;
2324 SvPVX(av) = (char*)ary;
2325 }
2326 }
2327 Copy(mark,AvARRAY(av),items,SV*);
93965878 2328 AvFILLp(av) = items - 1;
d8b46c1b 2329 assert(!AvREAL(av));
a0d0e21e
LW
2330 while (items--) {
2331 if (*mark)
2332 SvTEMP_off(*mark);
2333 mark++;
2334 }
2335 }
491527d0 2336 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2337 /*
2338 * We do not care about using sv to call CV;
2339 * it's for informational purposes only.
2340 */
3280af22 2341 SV *sv = GvSV(PL_DBsub);
491527d0
GS
2342 CV *gotocv;
2343
2344 if (PERLDB_SUB_NN) {
56431972 2345 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS
2346 } else {
2347 save_item(sv);
2348 gv_efullname3(sv, CvGV(cv), Nullch);
2349 }
2350 if ( PERLDB_GOTO
864dbfa3 2351 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2352 PUSHMARK( PL_stack_sp );
864dbfa3 2353 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2354 PL_stack_sp--;
491527d0 2355 }
1ce6579f 2356 }
a0d0e21e
LW
2357 RETURNOP(CvSTART(cv));
2358 }
2359 }
1614b0e3 2360 else {
2d8e6c8d 2361 label = SvPV(sv,n_a);
1614b0e3 2362 if (!(do_dump || *label))
cea2e8a9 2363 DIE(aTHX_ must_have_label);
1614b0e3 2364 }
a0d0e21e 2365 }
533c011a 2366 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2367 if (! do_dump)
cea2e8a9 2368 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2369 }
2370 else
2371 label = cPVOP->op_pv;
2372
2373 if (label && *label) {
2374 OP *gotoprobe = 0;
2375
2376 /* find label */
2377
3280af22 2378 PL_lastgotoprobe = 0;
a0d0e21e
LW
2379 *enterops = 0;
2380 for (ix = cxstack_ix; ix >= 0; ix--) {
2381 cx = &cxstack[ix];
6b35e009 2382 switch (CxTYPE(cx)) {
a0d0e21e 2383 case CXt_EVAL:
3280af22 2384 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW
2385 break;
2386 case CXt_LOOP:
2387 gotoprobe = cx->blk_oldcop->op_sibling;
2388 break;
2389 case CXt_SUBST:
2390 continue;
2391 case CXt_BLOCK:
2392 if (ix)
2393 gotoprobe = cx->blk_oldcop->op_sibling;
2394 else
3280af22 2395 gotoprobe = PL_main_root;
a0d0e21e 2396 break;
b3933176
CS
2397 case CXt_SUB:
2398 if (CvDEPTH(cx->blk_sub.cv)) {
2399 gotoprobe = CvROOT(cx->blk_sub.cv);
2400 break;
2401 }
2402 /* FALL THROUGH */
7766f137 2403 case CXt_FORMAT:
0a753a76 2404 case CXt_NULL:
a651a37d 2405 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2406 default:
2407 if (ix)
cea2e8a9 2408 DIE(aTHX_ "panic: goto");
3280af22 2409 gotoprobe = PL_main_root;
a0d0e21e
LW
2410 break;
2411 }
2b597662
GS
2412 if (gotoprobe) {
2413 retop = dofindlabel(gotoprobe, label,
2414 enterops, enterops + GOTO_DEPTH);
2415 if (retop)
2416 break;
2417 }
3280af22 2418 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2419 }
2420 if (!retop)
cea2e8a9 2421 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW
2422
2423 /* pop unwanted frames */
2424
2425 if (ix < cxstack_ix) {
2426 I32 oldsave;
2427
2428 if (ix < 0)
2429 ix = 0;
2430 dounwind(ix);
2431 TOPBLOCK(cx);
3280af22 2432 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2433 LEAVE_SCOPE(oldsave);
2434 }
2435
2436 /* push wanted frames */
2437
748a9306 2438 if (*enterops && enterops[1]) {
533c011a 2439 OP *oldop = PL_op;
748a9306 2440 for (ix = 1; enterops[ix]; ix++) {
533c011a 2441 PL_op = enterops[ix];
84902520
TB
2442 /* Eventually we may want to stack the needed arguments
2443 * for each op. For now, we punt on the hard ones. */
533c011a 2444 if (PL_op->op_type == OP_ENTERITER)
894356b3 2445 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2446 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2447 }
533c011a 2448 PL_op = oldop;
a0d0e21e
LW
2449 }
2450 }
2451
2452 if (do_dump) {
a5f75d66 2453#ifdef VMS
6b88bc9c 2454 if (!retop) retop = PL_main_start;
a5f75d66 2455#endif
3280af22
NIS
2456 PL_restartop = retop;
2457 PL_do_undump = TRUE;
a0d0e21e
LW
2458
2459 my_unexec();
2460
3280af22
NIS
2461 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2462 PL_do_undump = FALSE;
a0d0e21e
LW
2463 }
2464
2465 RETURNOP(retop);
2466}
2467
2468PP(pp_exit)
2469{
4e35701f 2470 djSP;
a0d0e21e
LW
2471 I32 anum;
2472
2473 if (MAXARG < 1)
2474 anum = 0;
ff0cee69 2475 else {
a0d0e21e 2476 anum = SvIVx(POPs);
d98f61e7
GS
2477#ifdef VMS
2478 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69
PP
2479 anum = 0;
2480#endif
2481 }
cc3604b1 2482 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2483 my_exit(anum);
3280af22 2484 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2485 RETURN;
2486}
2487
2488#ifdef NOTYET
2489PP(pp_nswitch)
2490{
4e35701f 2491 djSP;
65202027 2492 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW
2493 register I32 match = I_32(value);
2494
2495 if (value < 0.0) {
65202027 2496 if (((NV)match) > value)
a0d0e21e
LW
2497 --match; /* was fractional--truncate other way */
2498 }
2499 match -= cCOP->uop.scop.scop_offset;
2500 if (match < 0)
2501 match = 0;
2502 else if (match > cCOP->uop.scop.scop_max)
2503 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS
2504 PL_op = cCOP->uop.scop.scop_next[match];
2505 RETURNOP(PL_op);
a0d0e21e
LW
2506}
2507
2508PP(pp_cswitch)
2509{
4e35701f 2510 djSP;
a0d0e21e
LW
2511 register I32 match;
2512
6b88bc9c
GS
2513 if (PL_multiline)
2514 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2515 else {
2d8e6c8d
GS
2516 STRLEN n_a;
2517 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW
2518 match -= cCOP->uop.scop.scop_offset;
2519 if (match < 0)
2520 match = 0;
2521 else if (match > cCOP->uop.scop.scop_max)
2522 match = cCOP->uop.scop.scop_max;
6b88bc9c 2523 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2524 }
6b88bc9c 2525 RETURNOP(PL_op);
a0d0e21e
LW
2526}
2527#endif
2528
2529/* Eval. */
2530
0824fdcb 2531STATIC void
cea2e8a9 2532S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW
2533{
2534 register char *s = SvPVX(sv);
2535 register char *send = SvPVX(sv) + SvCUR(sv);
2536 register char *t;
2537 register I32 line = 1;
2538
2539 while (s && s < send) {
2540 SV *tmpstr = NEWSV(85,0);
2541
2542 sv_upgrade(tmpstr, SVt_PVMG);
2543 t = strchr(s, '\n');
2544 if (t)
2545 t++;
2546 else
2547 t = send;
2548
2549 sv_setpvn(tmpstr, s, t - s);
2550 av_store(array, line++, tmpstr);
2551 s = t;
2552 }
2553}
2554
14dd3ad8 2555#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2556STATIC void *
cea2e8a9 2557S_docatch_body(pTHX_ va_list args)
312caa8e 2558{
14dd3ad8
GS
2559 return docatch_body();
2560}
2561#endif
2562
2563STATIC void *
2564S_docatch_body(pTHX)
2565{
cea2e8a9 2566 CALLRUNOPS(aTHX);
312caa8e
CS
2567 return NULL;
2568}
2569
0824fdcb 2570STATIC OP *
cea2e8a9 2571S_docatch(pTHX_ OP *o)
1e422769 2572{
e858de61 2573 dTHR;
6224f72b 2574 int ret;
533c011a 2575 OP *oldop = PL_op;
0cdb2077 2576 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2577 dJMPENV;
1e422769 2578
1e422769 2579#ifdef DEBUGGING
54310121 2580 assert(CATCH_GET == TRUE);
1e422769 2581#endif
312caa8e 2582 PL_op = o;
14dd3ad8 2583#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2584 redo_body:
db36c5a1 2585 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
14dd3ad8
GS
2586#else
2587 JMPENV_PUSH(ret);
2588#endif
6224f72b 2589 switch (ret) {
312caa8e 2590 case 0:
14dd3ad8
GS
2591#ifndef PERL_FLEXIBLE_EXCEPTIONS
2592 redo_body:
2593 docatch_body();
2594#endif
312caa8e
CS
2595 break;
2596 case 3:
0cdb2077 2597 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS
2598 PL_op = PL_restartop;
2599 PL_restartop = 0;
2600 goto redo_body;
2601 }
2602 /* FALL THROUGH */
2603 default:
14dd3ad8 2604 JMPENV_POP;
533c011a 2605 PL_op = oldop;
6224f72b 2606 JMPENV_JUMP(ret);
1e422769 2607 /* NOTREACHED */
1e422769 2608 }
14dd3ad8 2609 JMPENV_POP;
533c011a 2610 PL_op = oldop;
1e422769
PP
2611 return Nullop;
2612}
2613
c277df42 2614OP *
864dbfa3 2615Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ
2616/* sv Text to convert to OP tree. */
2617/* startop op_free() this to undo. */
2618/* code Short string id of the caller. */
2619{
2620 dSP; /* Make POPBLOCK work. */
2621 PERL_CONTEXT *cx;
2622 SV **newsp;
f987c7de 2623 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ
2624 I32 optype;
2625 OP dummy;
155aba94 2626 OP *rop;
83ee9e09
GS
2627 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2628 char *tmpbuf = tbuf;
c277df42
IZ
2629 char *safestr;
2630
2631 ENTER;
2632 lex_start(sv);
2633 SAVETMPS;
2634 /* switch to eval mode */
2635
cbce877f 2636 if (PL_curcop == &PL_compiling) {
11faa288
GS
2637 SAVECOPSTASH(&PL_compiling);
2638 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2639 }
57843af0
GS
2640 SAVECOPFILE(&PL_compiling);
2641 SAVECOPLINE(&PL_compiling);
83ee9e09
GS
2642 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2643 SV *sv = sv_newmortal();
2644 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2645 code, (unsigned long)++PL_evalseq,
2646 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2647 tmpbuf = SvPVX(sv);
2648 }
2649 else
2650 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
57843af0
GS
2651 CopFILE_set(&PL_compiling, tmpbuf+2);
2652 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2653 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2654 deleting the eval's FILEGV from the stash before gv_check() runs
2655 (i.e. before run-time proper). To work around the coredump that
2656 ensues, we always turn GvMULTI_on for any globals that were
2657 introduced within evals. See force_ident(). GSAR 96-10-12 */
2658 safestr = savepv(tmpbuf);
3280af22 2659 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2660 SAVEHINTS();
d1ca3daa 2661#ifdef OP_IN_REGISTER
6b88bc9c 2662 PL_opsave = op;
d1ca3daa 2663#else
7766f137 2664 SAVEVPTR(PL_op);
d1ca3daa 2665#endif
3280af22 2666 PL_hints = 0;
c277df42 2667
533c011a 2668 PL_op = &dummy;
13b51b79 2669 PL_op->op_type = OP_ENTEREVAL;
533c011a 2670 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2671 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2672 PUSHEVAL(cx, 0, Nullgv);
c277df42 2673 rop = doeval(G_SCALAR, startop);
13b51b79 2674 POPBLOCK(cx,PL_curpm);
e84b9f1f 2675 POPEVAL(cx);
c277df42
IZ
2676
2677 (*startop)->op_type = OP_NULL;
22c35a8c 2678 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2679 lex_end();
3280af22 2680 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2681 LEAVE;
13b51b79 2682 if (PL_curcop == &PL_compiling)
a0ed51b3 2683 PL_compiling.op_private = PL_hints;
d1ca3daa 2684#ifdef OP_IN_REGISTER
6b88bc9c 2685 op = PL_opsave;
d1ca3daa 2686#endif
c277df42
IZ
2687 return rop;
2688}
2689
0f15f207 2690/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2691STATIC OP *
cea2e8a9 2692S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW
2693{
2694 dSP;
533c011a 2695 OP *saveop = PL_op;
ff3ff8d1 2696 CV *caller;
748a9306 2697 AV* comppadlist;
67a38de0 2698 I32 i;
a0d0e21e 2699
faef0170 2700 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2701
1ce6579f
PP
2702 PUSHMARK(SP);
2703
a0d0e21e
LW
2704 /* set up a scratch pad */
2705
3280af22 2706 SAVEI32(PL_padix);
7766f137 2707 SAVEVPTR(PL_curpad);
3280af22
NIS
2708 SAVESPTR(PL_comppad);
2709 SAVESPTR(PL_comppad_name);
2710 SAVEI32(PL_comppad_name_fill);
2711 SAVEI32(PL_min_intro_pending);
2712 SAVEI32(PL_max_intro_pending);
748a9306 2713
3280af22 2714 caller = PL_compcv;
6b35e009 2715 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2716 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2717 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2718 break;
7766f137 2719 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
67a38de0
NIS
2720 caller = cx->blk_sub.cv;
2721 break;
2722 }
2723 }
2724
3280af22
NIS
2725 SAVESPTR(PL_compcv);
2726 PL_compcv = (CV*)NEWSV(1104,0);
2727 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2728 CvEVAL_on(PL_compcv);
11343788 2729#ifdef USE_THREADS
533c011a
NIS
2730 CvOWNER(PL_compcv) = 0;
2731 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2732 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2733#endif /* USE_THREADS */
748a9306 2734
3280af22
NIS
2735 PL_comppad = newAV();
2736 av_push(PL_comppad, Nullsv);
2737 PL_curpad = AvARRAY(PL_comppad);
2738 PL_comppad_name = newAV();
2739 PL_comppad_name_fill = 0;
2740 PL_min_intro_pending = 0;
2741 PL_padix = 0;
11343788 2742#ifdef USE_THREADS
79cb57f6 2743 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS
2744 PL_curpad[0] = (SV*)newAV();
2745 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2746#endif /* USE_THREADS */
a0d0e21e 2747
748a9306
LW
2748 comppadlist = newAV();
2749 AvREAL_off(comppadlist);
3280af22
NIS
2750 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2751 av_store(comppadlist, 1, (SV*)PL_comppad);
2752 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2753
faa7e5bb
GS
2754 if (!saveop ||
2755 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2756 {
3280af22 2757 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
faa7e5bb 2758 }
07055b4c 2759
3280af22 2760 SAVEFREESV(PL_compcv);
748a9306 2761
a0d0e21e
LW
2762 /* make sure we compile in the right package */
2763
ed094faf 2764 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2765 SAVESPTR(PL_curstash);
ed094faf 2766 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2767 }
3280af22
NIS
2768 SAVESPTR(PL_beginav);
2769 PL_beginav = newAV();
2770 SAVEFREESV(PL_beginav);
24944567 2771 SAVEI32(PL_error_count);
a0d0e21e
LW
2772
2773 /* try to compile it */
2774
3280af22
NIS
2775 PL_eval_root = Nullop;
2776 PL_error_count = 0;
2777 PL_curcop = &PL_compiling;
2778 PL_curcop->cop_arybase = 0;
2779 SvREFCNT_dec(PL_rs);
79cb57f6 2780 PL_rs = newSVpvn("\n", 1);
c277df42 2781 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2782 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2783 else
38a03e6e 2784 sv_setpv(ERRSV,"");
3280af22 2785 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW
2786 SV **newsp;
2787 I32 gimme;
c09156bb 2788 PERL_CONTEXT *cx;
c277df42 2789 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2790 STRLEN n_a;
097ee67d 2791
533c011a 2792 PL_op = saveop;
3280af22
NIS
2793 if (PL_eval_root) {
2794 op_free(PL_eval_root);
2795 PL_eval_root = Nullop;
a0d0e21e 2796 }
3280af22 2797 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2798 if (!startop) {
3280af22 2799 POPBLOCK(cx,PL_curpm);
c277df42
IZ
2800 POPEVAL(cx);
2801 pop_return();
2802 }
a0d0e21e
LW
2803 lex_end();
2804 LEAVE;
7a2e2cd6 2805 if (optype == OP_REQUIRE) {
2d8e6c8d 2806 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS
2807 DIE(aTHX_ "%sCompilation failed in require",
2808 *msg ? msg : "Unknown error\n");
2809 }
2810 else if (startop) {
2d8e6c8d 2811 char* msg = SvPVx(ERRSV, n_a);
c277df42 2812
3280af22 2813 POPBLOCK(cx,PL_curpm);
c277df42 2814 POPEVAL(cx);
5a844595
GS
2815 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2816 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2817 }
3280af22
NIS
2818 SvREFCNT_dec(PL_rs);
2819 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2820#ifdef USE_THREADS
533c011a
NIS
2821 MUTEX_LOCK(&PL_eval_mutex);
2822 PL_eval_owner = 0;
2823 COND_SIGNAL(&PL_eval_cond);
2824 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2825#endif /* USE_THREADS */
a0d0e21e
LW
2826 RETPUSHUNDEF;
2827 }
3280af22
NIS
2828 SvREFCNT_dec(PL_rs);
2829 PL_rs = SvREFCNT_inc(PL_nrs);
57843af0 2830 CopLINE_set(&PL_compiling, 0);
c277df42 2831 if (startop) {
3280af22
NIS
2832 *startop = PL_eval_root;
2833 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2834 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2835 } else
3280af22 2836 SAVEFREEOP(PL_eval_root);
54310121 2837 if (gimme & G_VOID)
3280af22 2838 scalarvoid(PL_eval_root);
54310121 2839 else if (gimme & G_ARRAY)
3280af22 2840 list(PL_eval_root);
a0d0e21e 2841 else
3280af22 2842 scalar(PL_eval_root);
a0d0e21e
LW
2843
2844 DEBUG_x(dump_eval());
2845
55497cff 2846 /* Register with debugger: */
84902520 2847 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2848 CV *cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2849 if (cv) {
2850 dSP;
924508f0 2851 PUSHMARK(SP);
cc49e20b 2852 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2853 PUTBACK;
864dbfa3 2854 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
2855 }
2856 }
2857
a0d0e21e
LW
2858 /* compiled okay, so do it */
2859
3280af22
NIS
2860 CvDEPTH(PL_compcv) = 1;
2861 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2862 PL_op = saveop; /* The caller may need it. */
b35b2403 2863#ifdef USE_THREADS
533c011a
NIS
2864 MUTEX_LOCK(&PL_eval_mutex);
2865 PL_eval_owner = 0;
2866 COND_SIGNAL(&PL_eval_cond);
2867 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2868#endif /* USE_THREADS */
5dc0d613 2869
3280af22 2870 RETURNOP(PL_eval_start);
a0d0e21e
LW
2871}
2872
a6c40364 2873STATIC PerlIO *
cea2e8a9 2874S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH
2875{
2876 STRLEN namelen = strlen(name);
2877 PerlIO *fp;
2878
7894fbab 2879 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2880 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH
2881 char *pmc = SvPV_nolen(pmcsv);
2882 Stat_t pmstat;
a6c40364
GS
2883 Stat_t pmcstat;
2884 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2885 fp = PerlIO_open(name, mode);
a6c40364
GS
2886 }
2887 else {
b295d113 2888 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
2889 pmstat.st_mtime < pmcstat.st_mtime)
2890 {
2891 fp = PerlIO_open(pmc, mode);
2892 }
2893 else {
2894 fp = PerlIO_open(name, mode);
2895 }
b295d113 2896 }
a6c40364
GS
2897 SvREFCNT_dec(pmcsv);
2898 }
2899 else {
2900 fp = PerlIO_open(name, mode);
b295d113 2901 }
b295d113
TH
2902 return fp;
2903}
2904
a0d0e21e
LW
2905PP(pp_require)
2906{
4e35701f 2907 djSP;
c09156bb 2908 register PERL_CONTEXT *cx;
a0d0e21e
LW
2909 SV *sv;
2910 char *name;
6132ea6c 2911 STRLEN len;
46fc3d4c
PP
2912 char *tryname;
2913 SV *namesv = Nullsv;
a0d0e21e
LW
2914 SV** svp;
2915 I32 gimme = G_SCALAR;
760ac839 2916 PerlIO *tryrsfp = 0;
2d8e6c8d 2917 STRLEN n_a;
bbed91b5
KF
2918 int filter_has_file = 0;
2919 GV *filter_child_proc = 0;
2920 SV *filter_state = 0;
2921 SV *filter_sub = 0;
a0d0e21e
LW
2922
2923 sv = POPs;
a7cb1f99 2924 if (SvNIOKp(sv)) {
4305d8ab
GS
2925 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2926 UV rev = 0, ver = 0, sver = 0;
a7cb1f99
GS
2927 I32 len;
2928 U8 *s = (U8*)SvPVX(sv);
2929 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2930 if (s < end) {
2931 rev = utf8_to_uv(s, &len);
2932 s += len;
2933 if (s < end) {
2934 ver = utf8_to_uv(s, &len);
2935 s += len;
2936 if (s < end)
2937 sver = utf8_to_uv(s, &len);
a7cb1f99 2938 }
a7cb1f99 2939 }
a7cb1f99
GS
2940 if (PERL_REVISION < rev
2941 || (PERL_REVISION == rev
2942 && (PERL_VERSION < ver
2943 || (PERL_VERSION == ver
2944 && PERL_SUBVERSION < sver))))
2945 {
cc507455 2946 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
894356b3 2947 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS
2948 PERL_VERSION, PERL_SUBVERSION);
2949 }
4305d8ab 2950 RETPUSHYES;
a7cb1f99
GS
2951 }
2952 else if (!SvPOKp(sv)) { /* require 5.005_03 */
a7cb1f99
GS
2953 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2954 + ((NV)PERL_SUBVERSION/(NV)1000000)
2955 + 0.00000099 < SvNV(sv))
2956 {
dbe7b177
GS
2957 NV nrev = SvNV(sv);
2958 UV rev = (UV)nrev;
2959 NV nver = (nrev - rev) * 1000;
2960 UV ver = (UV)(nver + 0.0009);
2961 NV nsver = (nver - ver) * 1000;
2962 UV sver = (UV)(nsver + 0.0009);
2963
cc507455
GS
2964 /* help out with the "use 5.6" confusion */
2965 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2966 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2967 "this is only v%d.%d.%d, stopped"
2968 " (did you mean v%"UVuf".%"UVuf".0?)",
2969 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2970 PERL_SUBVERSION, rev, ver/100);
2971 }
2972 else {
2973 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2974 "this is only v%d.%d.%d, stopped",
2975 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2976 PERL_SUBVERSION);
2977 }
a7cb1f99 2978 }
4305d8ab 2979 RETPUSHYES;
a7cb1f99 2980 }
a0d0e21e 2981 }
6132ea6c
GS
2982 name = SvPV(sv, len);
2983 if (!(name && len > 0 && *name))
cea2e8a9 2984 DIE(aTHX_ "Null filename used");
4633a7c4 2985 TAINT_PROPER("require");
533c011a 2986 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS
2987 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2988 *svp != &PL_sv_undef)
a0d0e21e
LW
2989 RETPUSHYES;
2990
2991 /* prepare to compile file */
2992
57843af0
GS
2993 if (PERL_FILE_IS_ABSOLUTE(name)
2994 || (*name == '.' && (name[1] == '/' ||
2995 (name[1] == '.' && name[2] == '/'))))
a0d0e21e 2996 {
46fc3d4c 2997 tryname = name;
a6c40364 2998 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
bf4acbe4
GS
2999#ifdef MACOS_TRADITIONAL
3000 /* We consider paths of the form :a:b ambiguous and interpret them first
3001 as global then as local
3002 */
3003 if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3004 goto trylocal;
3005 }
3006 else
3007trylocal: {
3008#else
a0d0e21e
LW
3009 }
3010 else {
bf4acbe4 3011#endif
3280af22 3012 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3013 I32 i;
748a9306 3014#ifdef VMS
46fc3d4c
PP
3015 char *unixname;
3016 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3017#endif
3018 {
3019 namesv = NEWSV(806, 0);
3020 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
3021 SV *dirsv = *av_fetch(ar, i, TRUE);
3022
3023 if (SvROK(dirsv)) {
3024 int count;
3025 SV *loader = dirsv;
3026
3027 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3028 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3029 }
3030
b900a521
JH
3031 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3032 PTR2UV(SvANY(loader)), name);
bbed91b5
KF
3033 tryname = SvPVX(namesv);
3034 tryrsfp = 0;
3035
3036 ENTER;
3037 SAVETMPS;
3038 EXTEND(SP, 2);
3039
3040 PUSHMARK(SP);
3041 PUSHs(dirsv);
3042 PUSHs(sv);
3043 PUTBACK;
3044 count = call_sv(loader, G_ARRAY);
3045 SPAGAIN;
3046
3047 if (count > 0) {
3048 int i = 0;
3049 SV *arg;
3050
3051 SP -= count - 1;
3052 arg = SP[i++];
3053
3054 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3055 arg = SvRV(arg);
3056 }
3057
3058 if (SvTYPE(arg) == SVt_PVGV) {
3059 IO *io = GvIO((GV *)arg);
3060
3061 ++filter_has_file;
3062
3063 if (io) {
3064 tryrsfp = IoIFP(io);
3065 if (IoTYPE(io) == '|') {
3066 /* reading from a child process doesn't
3067 nest -- when returning from reading
3068 the inner module, the outer one is
3069 unreadable (closed?) I've tried to
3070 save the gv to manage the lifespan of
3071 the pipe, but this didn't help. XXX */
3072 filter_child_proc = (GV *)arg;
520c758a 3073 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
3074 }
3075 else {
3076 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3077 PerlIO_close(IoOFP(io));
3078 }
3079 IoIFP(io) = Nullfp;
3080 IoOFP(io) = Nullfp;
3081 }
3082 }
3083
3084 if (i < count) {
3085 arg = SP[i++];
3086 }
3087 }
3088
3089 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3090 filter_sub = arg;
520c758a 3091 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
3092
3093 if (i < count) {
3094 filter_state = SP[i];
520c758a 3095 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
3096 }
3097
3098 if (tryrsfp == 0) {
3099 tryrsfp = PerlIO_open("/dev/null",
3100 PERL_SCRIPT_MODE);
3101 }
3102 }
3103 }
3104
3105 PUTBACK;
3106 FREETMPS;
3107 LEAVE;
3108
3109 if (tryrsfp) {
3110 break;
3111 }
3112
3113 filter_has_file = 0;
3114 if (filter_child_proc) {
3115 SvREFCNT_dec(filter_child_proc);
3116 filter_child_proc = 0;
3117 }
3118 if (filter_state) {
3119 SvREFCNT_dec(filter_state);
3120 filter_state = 0;
3121 }
3122 if (filter_sub) {
3123 SvREFCNT_dec(filter_sub);
3124 filter_sub = 0;
3125 }
3126 }
3127 else {
3128 char *dir = SvPVx(dirsv, n_a);
bf4acbe4
GS
3129#ifdef MACOS_TRADITIONAL
3130 /* We have ensured in incpush that library ends with ':' */
3131 Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':'));
3132#else
46fc3d4c 3133#ifdef VMS
bbed91b5
KF
3134 char *unixdir;
3135 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3136 continue;
3137 sv_setpv(namesv, unixdir);
3138 sv_catpv(namesv, unixname);
748a9306 3139#else
bbed91b5 3140 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3141#endif
bf4acbe4 3142#endif
bbed91b5
KF
3143 TAINT_PROPER("require");
3144 tryname = SvPVX(namesv);
bf4acbe4
GS
3145#ifdef MACOS_TRADITIONAL
3146 {
3147 /* Convert slashes in the name part, but not the directory part, to colons */
3148 char * colon;
3149 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3150 *colon++ = ':';
3151 }
3152#endif
bbed91b5
KF
3153 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3154 if (tryrsfp) {
3155 if (tryname[0] == '.' && tryname[1] == '/')
3156 tryname += 2;
3157 break;
3158 }
46fc3d4c 3159 }
a0d0e21e
LW
3160 }
3161 }
3162 }
57843af0
GS
3163 SAVECOPFILE(&PL_compiling);
3164 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3165 SvREFCNT_dec(namesv);
a0d0e21e 3166 if (!tryrsfp) {
533c011a 3167 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS
3168 char *msgstr = name;
3169 if (namesv) { /* did we lookup @INC? */
3170 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3171 SV *dirmsgsv = NEWSV(0, 0);
3172 AV *ar = GvAVn(PL_incgv);
3173 I32 i;
3174 sv_catpvn(msg, " in @INC", 8);
3175 if (instr(SvPVX(msg), ".h "))
3176 sv_catpv(msg, " (change .h to .ph maybe?)");
3177 if (instr(SvPVX(msg), ".ph "))
3178 sv_catpv(msg, " (did you run h2ph?)");
3179 sv_catpv(msg, " (@INC contains:");
3180 for (i = 0; i <= AvFILL(ar); i++) {
3181 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3182 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS
3183 sv_catsv(msg, dirmsgsv);
3184 }
3185 sv_catpvn(msg, ")", 1);
3186 SvREFCNT_dec(dirmsgsv);
3187 msgstr = SvPV_nolen(msg);
2683423c 3188 }
cea2e8a9 3189 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
3190 }
3191
3192 RETPUSHUNDEF;
3193 }
d8bfb8bd 3194 else
aba27d88 3195 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW
3196
3197 /* Assume success here to prevent recursive requirement. */
3280af22 3198 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
ed094faf 3199 newSVpv(CopFILE(&PL_compiling), 0), 0 );
a0d0e21e
LW
3200
3201 ENTER;
3202 SAVETMPS;
79cb57f6 3203 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS
3204 SAVEGENERICSV(PL_rsfp_filters);
3205 PL_rsfp_filters = Nullav;
e50aee73 3206
3280af22 3207 PL_rsfp = tryrsfp;
b3ac6de7 3208 SAVEHINTS();
3280af22 3209 PL_hints = 0;
7766f137 3210 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3211 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3212 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3213 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3214 PL_compiling.cop_warnings = pWARN_NONE ;
0453d815 3215 else
d3a7d8c7 3216 PL_compiling.cop_warnings = pWARN_STD ;
a0d0e21e 3217
bbed91b5
KF
3218 if (filter_sub || filter_child_proc) {
3219 SV *datasv = filter_add(run_user_filter, Nullsv);
3220 IoLINES(datasv) = filter_has_file;
3221 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3222 IoTOP_GV(datasv) = (GV *)filter_state;
3223 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3224 }
3225
3226 /* switch to eval mode */
533c011a 3227 push_return(PL_op->op_next);
a0d0e21e 3228 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3229 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3230
57843af0
GS
3231 SAVECOPLINE(&PL_compiling);
3232 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW
3233
3234 PUTBACK;
0f15f207 3235#ifdef USE_THREADS
533c011a
NIS
3236 MUTEX_LOCK(&PL_eval_mutex);
3237 if (PL_eval_owner && PL_eval_owner != thr)
3238 while (PL_eval_owner)
3239 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3240 PL_eval_owner = thr;
3241 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3242#endif /* USE_THREADS */
c277df42 3243 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW
3244}
3245
3246PP(pp_dofile)
3247{
cea2e8a9 3248 return pp_require();
a0d0e21e
LW
3249}
3250
3251PP(pp_entereval)
3252{
4e35701f 3253 djSP;
c09156bb 3254 register PERL_CONTEXT *cx;
a0d0e21e 3255 dPOPss;
3280af22 3256 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS
3257 char tbuf[TYPE_DIGITS(long) + 12];
3258 char *tmpbuf = tbuf;
fc36a67e 3259 char *safestr;
a0d0e21e 3260 STRLEN len;
55497cff 3261 OP *ret;
a0d0e21e
LW
3262
3263 if (!SvPV(sv,len) || !len)
3264 RETPUSHUNDEF;
748a9306 3265 TAINT_PROPER("eval");
a0d0e21e
LW
3266
3267 ENTER;
a0d0e21e 3268 lex_start(sv);
748a9306 3269 SAVETMPS;
a0d0e21e
LW
3270
3271 /* switch to eval mode */
3272
57843af0 3273 SAVECOPFILE(&PL_compiling);
83ee9e09
GS
3274 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3275 SV *sv = sv_newmortal();
3276 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3277 (unsigned long)++PL_evalseq,
3278 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3279 tmpbuf = SvPVX(sv);
3280 }
3281 else
3282 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
57843af0
GS
3283 CopFILE_set(&PL_compiling, tmpbuf+2);
3284 CopLINE_set(&PL_compiling, 1);
55497cff
PP
3285 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3286 deleting the eval's FILEGV from the stash before gv_check() runs
3287 (i.e. before run-time proper). To work around the coredump that
3288 ensues, we always turn GvMULTI_on for any globals that were
3289 introduced within evals. See force_ident(). GSAR 96-10-12 */
3290 safestr = savepv(tmpbuf);
3280af22 3291 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3292 SAVEHINTS();
533c011a 3293 PL_hints = PL_op->op_targ;
7766f137 3294 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS
3295 if (specialWARN(PL_curcop->cop_warnings))
3296 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3297 else {
3298 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3299 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3300 }
a0d0e21e 3301
533c011a 3302 push_return(PL_op->op_next);
6b35e009 3303 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3304 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW
3305
3306 /* prepare to compile string */
3307
3280af22 3308 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3309 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3310 PUTBACK;
0f15f207 3311#ifdef USE_THREADS
533c011a
NIS
3312 MUTEX_LOCK(&PL_eval_mutex);
3313 if (PL_eval_owner && PL_eval_owner != thr)
3314 while (PL_eval_owner)
3315 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3316 PL_eval_owner = thr;
3317 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3318#endif /* USE_THREADS */
c277df42 3319 ret = doeval(gimme, NULL);
3280af22 3320 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3321 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff
PP
3322 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3323 }
1e422769 3324 return DOCATCH(ret);
a0d0e21e
LW
3325}
3326
3327PP(pp_leaveeval)
3328{
4e35701f 3329 djSP;
a0d0e21e
LW
3330 register SV **mark;
3331 SV **newsp;
3332 PMOP *newpm;
3333 I32 gimme;
c09156bb 3334 register PERL_CONTEXT *cx;
a0d0e21e 3335 OP *retop;
533c011a 3336 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW
3337 I32 optype;
3338
3339 POPBLOCK(cx,newpm);
3340 POPEVAL(cx);
3341 retop = pop_return();
3342
a1f49e72 3343 TAINT_NOT;
54310121
PP
3344 if (gimme == G_VOID)
3345 MARK = newsp;
3346 else if (gimme == G_SCALAR) {
3347 MARK = newsp + 1;
3348 if (MARK <= SP) {
3349 if (SvFLAGS(TOPs) & SVs_TEMP)
3350 *MARK = TOPs;
3351 else
3352 *MARK = sv_mortalcopy(TOPs);
3353 }
a0d0e21e 3354 else {
54310121 3355 MEXTEND(mark,0);
3280af22 3356 *MARK = &PL_sv_undef;
a0d0e21e 3357 }
a7ec2b44 3358 SP = MARK;
a0d0e21e
LW
3359 }
3360 else {
a1f49e72
CS
3361 /* in case LEAVE wipes old return values */
3362 for (mark = newsp + 1; mark <= SP; mark++) {
3363 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3364 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3365 TAINT_NOT; /* Each item is independent */
3366 }
3367 }
a0d0e21e 3368 }
3280af22 3369 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3370
067f92a0
GS
3371 if (AvFILLp(PL_comppad_name) >= 0)
3372 free_closures();
84902520 3373
4fdae800 3374#ifdef DEBUGGING
3280af22 3375 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3376#endif
3280af22 3377 CvDEPTH(PL_compcv) = 0;
f46d017c 3378 lex_end();
4fdae800 3379
1ce6579f 3380 if (optype == OP_REQUIRE &&
924508f0 3381 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3382 {
1ce6579f 3383 /* Unassume the success we assumed earlier. */
0f79a09d
GS
3384 SV *nsv = cx->blk_eval.old_namesv;
3385 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3386 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
f46d017c
GS
3387 /* die_where() did LEAVE, or we won't be here */
3388 }
3389 else {
3390 LEAVE;
3391 if (!(save_flags & OPf_SPECIAL))
3392 sv_setpv(ERRSV,"");
a0d0e21e 3393 }
a0d0e21e
LW
3394
3395 RETURNOP(retop);
3396}
3397
a0d0e21e
LW
3398PP(pp_entertry)
3399{
4e35701f 3400 djSP;
c09156bb 3401 register PERL_CONTEXT *cx;
54310121 3402 I32 gimme = GIMME_V;
a0d0e21e
LW
3403
3404 ENTER;
3405 SAVETMPS;
3406
3407 push_return(cLOGOP->op_other->op_next);
1d76a5c3 3408 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
a0d0e21e 3409 PUSHEVAL(cx, 0, 0);
533c011a 3410 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3411
faef0170 3412 PL_in_eval = EVAL_INEVAL;
38a03e6e 3413 sv_setpv(ERRSV,"");
1e422769 3414 PUTBACK;
533c011a 3415 return DOCATCH(PL_op->op_next);
a0d0e21e
LW
3416}
3417
3418PP(pp_leavetry)
3419{
4e35701f 3420 djSP;
a0d0e21e
LW
3421 register SV **mark;
3422 SV **newsp;
3423 PMOP *newpm;
3424 I32 gimme;
c09156bb 3425 register PERL_CONTEXT *cx;
a0d0e21e
LW
3426 I32 optype;
3427
3428 POPBLOCK(cx,newpm);
3429 POPEVAL(cx);
3430 pop_return();
3431
a1f49e72 3432 TAINT_NOT;
54310121
PP
3433 if (gimme == G_VOID)
3434 SP = newsp;
3435 else if (gimme == G_SCALAR) {
3436 MARK = newsp + 1;
3437 if (MARK <= SP) {
3438 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3439 *MARK = TOPs;
3440 else
3441 *MARK = sv_mortalcopy(TOPs);
3442 }
a0d0e21e 3443 else {
54310121 3444 MEXTEND(mark,0);
3280af22 3445 *MARK = &PL_sv_undef;
a0d0e21e
LW
3446 }
3447 SP = MARK;
3448 }
3449 else {
a1f49e72
CS
3450 /* in case LEAVE wipes old return values */
3451 for (mark = newsp + 1; mark <= SP; mark++) {
3452 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3453 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3454 TAINT_NOT; /* Each item is independent */
3455 }
3456 }
a0d0e21e 3457 }
3280af22 3458 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
3459
3460 LEAVE;
38a03e6e 3461 sv_setpv(ERRSV,"");
a0d0e21e
LW
3462 RETURN;
3463}
3464
0824fdcb 3465STATIC void
cea2e8a9 3466S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW
3467{
3468 STRLEN len;
3469 register char *s = SvPV_force(sv, len);
3470 register char *send = s + len;
3471 register char *base;
3472 register I32 skipspaces = 0;
3473 bool noblank;
3474 bool repeat;
3475 bool postspace = FALSE;
3476 U16 *fops;
3477 register U16 *fpc;
3478 U16 *linepc;
3479 register I32 arg;
3480 bool ischop;
3481
55497cff 3482 if (len == 0)
cea2e8a9 3483 Perl_croak(aTHX_ "Null picture in formline");
55497cff
PP
3484
3485 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW
3486 fpc = fops;
3487
3488 if (s < send) {
3489 linepc = fpc;
3490 *fpc++ = FF_LINEMARK;
3491 noblank = repeat = FALSE;
3492 base = s;
3493 }
3494
3495 while (s <= send) {
3496 switch (*s++) {
3497 default:
3498 skipspaces = 0;
3499 continue;
3500
3501 case '~':
3502 if (*s == '~') {
3503 repeat = TRUE;
3504 *s = ' ';
3505 }
3506 noblank = TRUE;
3507 s[-1] = ' ';
3508 /* FALL THROUGH */
3509 case ' ': case '\t':
3510 skipspaces++;
3511 continue;
3512
3513 case '\n': case 0:
3514 arg = s - base;
3515 skipspaces++;
3516 arg -= skipspaces;
3517 if (arg) {
5f05dabc 3518 if (postspace)
a0d0e21e 3519 *fpc++ = FF_SPACE;
a0d0e21e
LW
3520 *fpc++ = FF_LITERAL;
3521 *fpc++ = arg;
3522 }
5f05dabc 3523 postspace = FALSE;
a0d0e21e
LW
3524 if (s <= send)
3525 skipspaces--;
3526 if (skipspaces) {
3527 *fpc++ = FF_SKIP;
3528 *fpc++ = skipspaces;
3529 }
3530 skipspaces = 0;
3531 if (s <= send)
3532 *fpc++ = FF_NEWLINE;
3533 if (noblank) {
3534 *fpc++ = FF_BLANK;
3535 if (repeat)
3536 arg = fpc - linepc + 1;
3537 else
3538 arg = 0;
3539 *fpc++ = arg;
3540 }
3541 if (s < send) {
3542 linepc = fpc;
3543 *fpc++ = FF_LINEMARK;
3544 noblank = repeat = FALSE;
3545 base = s;
3546 }
3547 else
3548 s++;
3549 continue;
3550
3551 case '@':
3552 case '^':
3553 ischop = s[-1] == '^';
3554
3555 if (postspace) {
3556 *fpc++ = FF_SPACE;
3557 postspace = FALSE;
3558 }
3559 arg = (s - base) - 1;
3560 if (arg) {
3561 *fpc++ = FF_LITERAL;
3562 *fpc++ = arg;
3563 }
3564
3565 base = s - 1;
3566 *fpc++ = FF_FETCH;
3567 if (*s == '*') {
3568 s++;
3569 *fpc++ = 0;
3570 *fpc++ = FF_LINEGLOB;
3571 }
3572 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3573 arg = ischop ? 512 : 0;
3574 base = s - 1;
3575 while (*s == '#')
3576 s++;
3577 if (*s == '.') {
3578 char *f;
3579 s++;
3580 f = s;
3581 while (*s == '#')
3582 s++;
3583 arg |= 256 + (s - f);
3584 }