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