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