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