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