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