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