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