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