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