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