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