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