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