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