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