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