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
regexec.c utf8 loading
[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;
a0d0e21e
LW		 1705
1706 if (MAXARG < 1)
1707 tmps = "";
1708 else
e62f0680 1709 tmps = POPpconstx;
11faa288 1710 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1711 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1712 RETURN;
1713}
1714
1715PP(pp_lineseq)
1716{
1717 return NORMAL;
1718}
1719
dd2155a4
DM		 1720/* like pp_nextstate, but used instead when the debugger is active */
1721
a0d0e21e
LW		 1722PP(pp_dbstate)
1723{
27da23d5 1724 dVAR;
533c011a 1725 PL_curcop = (COP*)PL_op;
a0d0e21e 1726 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1727 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1728 FREETMPS;
1729
5df8de69
DM		 1730 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1731 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1732 {
39644a26 1733 dSP;
a0d0e21e 1734 register CV *cv;
c09156bb 1735 register PERL_CONTEXT *cx;
f54cb97a 1736 const I32 gimme = G_ARRAY;
eb160463 1737 U8 hasargs;
a0d0e21e
LW		 1738 GV *gv;
1739
3280af22 1740 gv = PL_DBgv;
a0d0e21e 1741 cv = GvCV(gv);
a0d0e21e 1742 if (!cv)
cea2e8a9 1743 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1744
aea4f609
DM		 1745 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1746 /* don't do recursive DB::DB call */
a0d0e21e 1747 return NORMAL;
748a9306 1748
4633a7c4
LW		 1749 ENTER;
1750 SAVETMPS;
1751
3280af22 1752 SAVEI32(PL_debug);
55497cff 1753 SAVESTACK_POS();
3280af22 1754 PL_debug = 0;
748a9306 1755 hasargs = 0;
924508f0 1756 SPAGAIN;
748a9306 1757
924508f0 1758 PUSHBLOCK(cx, CXt_SUB, SP);
ee98a1d6 1759 PUSHSUB_DB(cx);
f39bc417 1760 cx->blk_sub.retop = PL_op->op_next;
a0d0e21e 1761 CvDEPTH(cv)++;
dd2155a4 1762 PAD_SET_CUR(CvPADLIST(cv),1);
a0d0e21e
LW		 1763 RETURNOP(CvSTART(cv));
1764 }
1765 else
1766 return NORMAL;
1767}
1768
1769PP(pp_scope)
1770{
1771 return NORMAL;
1772}
1773
1774PP(pp_enteriter)
1775{
27da23d5 1776 dVAR; dSP; dMARK;
c09156bb 1777 register PERL_CONTEXT *cx;
f54cb97a 1778 const I32 gimme = GIMME_V;
a0d0e21e 1779 SV **svp;
7766f137
GS		 1780 U32 cxtype = CXt_LOOP;
1781#ifdef USE_ITHREADS
1782 void *iterdata;
1783#endif
a0d0e21e 1784
4633a7c4
LW		 1785 ENTER;
1786 SAVETMPS;
1787
533c011a 1788 if (PL_op->op_targ) {
14f338dc
DM		 1789 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1790 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1791 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1792 SVs_PADSTALE, SVs_PADSTALE);
1793 }
c3564e5c 1794#ifndef USE_ITHREADS
dd2155a4 1795 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
54b9620d 1796 SAVESPTR(*svp);
c3564e5c
GS		 1797#else
1798 SAVEPADSV(PL_op->op_targ);
cbfa9890 1799 iterdata = INT2PTR(void*, PL_op->op_targ);
7766f137
GS		 1800 cxtype |= CXp_PADVAR;
1801#endif
54b9620d
MB		 1802 }
1803 else {
7766f137
GS		 1804 GV *gv = (GV*)POPs;
1805 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1806 SAVEGENERICSV(*svp);
1807 *svp = NEWSV(0,0);
7766f137
GS		 1808#ifdef USE_ITHREADS
1809 iterdata = (void*)gv;
1810#endif
54b9620d 1811 }
4633a7c4 1812
a0d0e21e
LW		 1813 ENTER;
1814
7766f137
GS		 1815 PUSHBLOCK(cx, cxtype, SP);
1816#ifdef USE_ITHREADS
1817 PUSHLOOP(cx, iterdata, MARK);
1818#else
a0d0e21e 1819 PUSHLOOP(cx, svp, MARK);
7766f137 1820#endif
533c011a 1821 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1822 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1823 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1824 dPOPss;
4fe3f0fa
MHM		 1825 SV *right = (SV*)cx->blk_loop.iterary;
1826 if (RANGE_IS_NUMERIC(sv,right)) {
1827 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1828 (SvOK(right) && SvNV(right) >= IV_MAX))
076d9a11
MHM		 1829 DIE(aTHX_ "Range iterator outside integer range");
1830 cx->blk_loop.iterix = SvIV(sv);
4fe3f0fa 1831 cx->blk_loop.itermax = SvIV(right);
89ea2908 1832 }
3f63a782
MHM		 1833 else {
1834 STRLEN n_a;
89ea2908 1835 cx->blk_loop.iterlval = newSVsv(sv);
4fe3f0fa 1836 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
10516c54 1837 (void) SvPV_nolen_const(right);
3f63a782 1838 }
89ea2908 1839 }
ef3e5ea9 1840 else if (PL_op->op_private & OPpITER_REVERSED) {
e682d7b7 1841 cx->blk_loop.itermax = -1;
ef3e5ea9
NC		 1842 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1843
1844 }
89ea2908 1845 }
4633a7c4 1846 else {
3280af22
NIS		 1847 cx->blk_loop.iterary = PL_curstack;
1848 AvFILLp(PL_curstack) = SP - PL_stack_base;
ef3e5ea9
NC		 1849 if (PL_op->op_private & OPpITER_REVERSED) {
1850 cx->blk_loop.itermax = MARK - PL_stack_base;
1851 cx->blk_loop.iterix = cx->blk_oldsp;
1852 }
1853 else {
1854 cx->blk_loop.iterix = MARK - PL_stack_base;
1855 }
4633a7c4 1856 }
a0d0e21e
LW		 1857
1858 RETURN;
1859}
1860
1861PP(pp_enterloop)
1862{
27da23d5 1863 dVAR; dSP;
c09156bb 1864 register PERL_CONTEXT *cx;
f54cb97a 1865 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1866
1867 ENTER;
1868 SAVETMPS;
1869 ENTER;
1870
1871 PUSHBLOCK(cx, CXt_LOOP, SP);
1872 PUSHLOOP(cx, 0, SP);
1873
1874 RETURN;
1875}
1876
1877PP(pp_leaveloop)
1878{
27da23d5 1879 dVAR; dSP;
c09156bb 1880 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1881 I32 gimme;
1882 SV **newsp;
1883 PMOP *newpm;
1884 SV **mark;
1885
1886 POPBLOCK(cx,newpm);
3a1b2b9e 1887 assert(CxTYPE(cx) == CXt_LOOP);
4fdae800 1888 mark = newsp;
a8bba7fa 1889 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1890
a1f49e72 1891 TAINT_NOT;
54310121 1892 if (gimme == G_VOID)
1893 ; /* do nothing */
1894 else if (gimme == G_SCALAR) {
1895 if (mark < SP)
1896 *++newsp = sv_mortalcopy(*SP);
1897 else
3280af22 1898 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1899 }
1900 else {
a1f49e72 1901 while (mark < SP) {
a0d0e21e 1902 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1903 TAINT_NOT; /* Each item is independent */
1904 }
a0d0e21e 1905 }
f86702cc 1906 SP = newsp;
1907 PUTBACK;
1908
a8bba7fa 1909 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1910 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1911
a0d0e21e
LW		 1912 LEAVE;
1913 LEAVE;
1914
f86702cc 1915 return NORMAL;
a0d0e21e
LW		 1916}
1917
1918PP(pp_return)
1919{
27da23d5 1920 dVAR; dSP; dMARK;
a0d0e21e 1921 I32 cxix;
c09156bb 1922 register PERL_CONTEXT *cx;
f86702cc 1923 bool popsub2 = FALSE;
b45de488 1924 bool clear_errsv = FALSE;
a0d0e21e
LW		 1925 I32 gimme;
1926 SV **newsp;
1927 PMOP *newpm;
1928 I32 optype = 0;
b0d9ce38 1929 SV *sv;
f39bc417 1930 OP *retop;
a0d0e21e 1931
3280af22 1932 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS		 1933 if (cxstack_ix == PL_sortcxix
1934 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1935 {
3280af22
NIS		 1936 if (cxstack_ix > PL_sortcxix)
1937 dounwind(PL_sortcxix);
1938 AvARRAY(PL_curstack)[1] = *SP;
1939 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1940 return 0;
1941 }
1942 }
1943
1944 cxix = dopoptosub(cxstack_ix);
1945 if (cxix < 0)
cea2e8a9 1946 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1947 if (cxix < cxstack_ix)
1948 dounwind(cxix);
1949
1950 POPBLOCK(cx,newpm);
6b35e009 1951 switch (CxTYPE(cx)) {
a0d0e21e 1952 case CXt_SUB:
f86702cc 1953 popsub2 = TRUE;
f39bc417 1954 retop = cx->blk_sub.retop;
5dd42e15 1955 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
a0d0e21e
LW		 1956 break;
1957 case CXt_EVAL:
b45de488
GS		 1958 if (!(PL_in_eval & EVAL_KEEPERR))
1959 clear_errsv = TRUE;
a0d0e21e 1960 POPEVAL(cx);
f39bc417 1961 retop = cx->blk_eval.retop;
1d76a5c3
GS		 1962 if (CxTRYBLOCK(cx))
1963 break;
067f92a0 1964 lex_end();
748a9306
LW		 1965 if (optype == OP_REQUIRE &&
1966 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1967 {
54310121 1968 /* Unassume the success we assumed earlier. */
0f79a09d 1969 SV *nsv = cx->blk_eval.old_namesv;
b15aece3 1970 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
35c1215d 1971 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
748a9306 1972 }
a0d0e21e 1973 break;
7766f137
GS		 1974 case CXt_FORMAT:
1975 POPFORMAT(cx);
f39bc417 1976 retop = cx->blk_sub.retop;
7766f137 1977 break;
a0d0e21e 1978 default:
cea2e8a9 1979 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1980 }
1981
a1f49e72 1982 TAINT_NOT;
a0d0e21e 1983 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1984 if (MARK < SP) {
1985 if (popsub2) {
a8bba7fa 1986 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 1987 if (SvTEMP(TOPs)) {
1988 *++newsp = SvREFCNT_inc(*SP);
1989 FREETMPS;
1990 sv_2mortal(*newsp);
959e3673
GS		 1991 }
1992 else {
1993 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 1994 FREETMPS;
959e3673
GS		 1995 *++newsp = sv_mortalcopy(sv);
1996 SvREFCNT_dec(sv);
a29cdaf0 1997 }
959e3673
GS		 1998 }
1999 else
a29cdaf0 2000 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 2001 }
2002 else
a29cdaf0 2003 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 2004 }
2005 else
3280af22 2006 *++newsp = &PL_sv_undef;
a0d0e21e 2007 }
54310121 2008 else if (gimme == G_ARRAY) {
a1f49e72 2009 while (++MARK <= SP) {
f86702cc 2010 *++newsp = (popsub2 && SvTEMP(*MARK))
2011 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2012 TAINT_NOT; /* Each item is independent */
2013 }
a0d0e21e 2014 }
3280af22 2015 PL_stack_sp = newsp;
a0d0e21e 2016
5dd42e15 2017 LEAVE;
f86702cc 2018 /* Stack values are safe: */
2019 if (popsub2) {
5dd42e15 2020 cxstack_ix--;
b0d9ce38 2021 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2022 }
b0d9ce38
GS		 2023 else
2024 sv = Nullsv;
3280af22 2025 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 2026
b0d9ce38 2027 LEAVESUB(sv);
b45de488 2028 if (clear_errsv)
c69006e4 2029 sv_setpvn(ERRSV,"",0);
f39bc417 2030 return retop;
a0d0e21e
LW		 2031}
2032
2033PP(pp_last)
2034{
27da23d5 2035 dVAR; dSP;
a0d0e21e 2036 I32 cxix;
c09156bb 2037 register PERL_CONTEXT *cx;
f86702cc 2038 I32 pop2 = 0;
a0d0e21e
LW		 2039 I32 gimme;
2040 I32 optype;
2041 OP *nextop;
2042 SV **newsp;
2043 PMOP *newpm;
a8bba7fa 2044 SV **mark;
b0d9ce38 2045 SV *sv = Nullsv;
a0d0e21e 2046
533c011a 2047 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2048 cxix = dopoptoloop(cxstack_ix);
2049 if (cxix < 0)
a651a37d 2050 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 2051 }
2052 else {
2053 cxix = dopoptolabel(cPVOP->op_pv);
2054 if (cxix < 0)
cea2e8a9 2055 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2056 }
2057 if (cxix < cxstack_ix)
2058 dounwind(cxix);
2059
2060 POPBLOCK(cx,newpm);
5dd42e15 2061 cxstack_ix++; /* temporarily protect top context */
a8bba7fa 2062 mark = newsp;
6b35e009 2063 switch (CxTYPE(cx)) {
a0d0e21e 2064 case CXt_LOOP:
f86702cc 2065 pop2 = CXt_LOOP;
a8bba7fa
GS		 2066 newsp = PL_stack_base + cx->blk_loop.resetsp;
2067 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 2068 break;
f86702cc 2069 case CXt_SUB:
f86702cc 2070 pop2 = CXt_SUB;
f39bc417 2071 nextop = cx->blk_sub.retop;
a0d0e21e 2072 break;
f86702cc 2073 case CXt_EVAL:
2074 POPEVAL(cx);
f39bc417 2075 nextop = cx->blk_eval.retop;
a0d0e21e 2076 break;
7766f137
GS		 2077 case CXt_FORMAT:
2078 POPFORMAT(cx);
f39bc417 2079 nextop = cx->blk_sub.retop;
7766f137 2080 break;
a0d0e21e 2081 default:
cea2e8a9 2082 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 2083 }
2084
a1f49e72 2085 TAINT_NOT;
a0d0e21e 2086 if (gimme == G_SCALAR) {
f86702cc 2087 if (MARK < SP)
2088 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2089 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 2090 else
3280af22 2091 *++newsp = &PL_sv_undef;
a0d0e21e 2092 }
54310121 2093 else if (gimme == G_ARRAY) {
a1f49e72 2094 while (++MARK <= SP) {
f86702cc 2095 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2096 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 2097 TAINT_NOT; /* Each item is independent */
2098 }
f86702cc 2099 }
2100 SP = newsp;
2101 PUTBACK;
2102
5dd42e15
DM		 2103 LEAVE;
2104 cxstack_ix--;
f86702cc 2105 /* Stack values are safe: */
2106 switch (pop2) {
2107 case CXt_LOOP:
a8bba7fa 2108 POPLOOP(cx); /* release loop vars ... */
4fdae800 2109 LEAVE;
f86702cc 2110 break;
2111 case CXt_SUB:
b0d9ce38 2112 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 2113 break;
a0d0e21e 2114 }
3280af22 2115 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e 2116
b0d9ce38 2117 LEAVESUB(sv);
f86702cc 2118 return nextop;
a0d0e21e
LW		 2119}
2120
2121PP(pp_next)
2122{
27da23d5 2123 dVAR;
a0d0e21e 2124 I32 cxix;
c09156bb 2125 register PERL_CONTEXT *cx;
85538317 2126 I32 inner;
a0d0e21e 2127
533c011a 2128 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2129 cxix = dopoptoloop(cxstack_ix);
2130 if (cxix < 0)
a651a37d 2131 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 2132 }
2133 else {
2134 cxix = dopoptolabel(cPVOP->op_pv);
2135 if (cxix < 0)
cea2e8a9 2136 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2137 }
2138 if (cxix < cxstack_ix)
2139 dounwind(cxix);
2140
85538317
GS		 2141 /* clear off anything above the scope we're re-entering, but
2142 * save the rest until after a possible continue block */
2143 inner = PL_scopestack_ix;
1ba6ee2b 2144 TOPBLOCK(cx);
85538317
GS		 2145 if (PL_scopestack_ix < inner)
2146 leave_scope(PL_scopestack[PL_scopestack_ix]);
3a1b2b9e 2147 PL_curcop = cx->blk_oldcop;
1ba6ee2b 2148 return cx->blk_loop.next_op;
a0d0e21e
LW		 2149}
2150
2151PP(pp_redo)
2152{
27da23d5 2153 dVAR;
a0d0e21e 2154 I32 cxix;
c09156bb 2155 register PERL_CONTEXT *cx;
a0d0e21e 2156 I32 oldsave;
a034e688 2157 OP* redo_op;
a0d0e21e 2158
533c011a 2159 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2160 cxix = dopoptoloop(cxstack_ix);
2161 if (cxix < 0)
a651a37d 2162 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2163 }
2164 else {
2165 cxix = dopoptolabel(cPVOP->op_pv);
2166 if (cxix < 0)
cea2e8a9 2167 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2168 }
2169 if (cxix < cxstack_ix)
2170 dounwind(cxix);
2171
a034e688
DM		 2172 redo_op = cxstack[cxix].blk_loop.redo_op;
2173 if (redo_op->op_type == OP_ENTER) {
2174 /* pop one less context to avoid $x being freed in while (my $x..) */
2175 cxstack_ix++;
2176 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2177 redo_op = redo_op->op_next;
2178 }
2179
a0d0e21e 2180 TOPBLOCK(cx);
3280af22 2181 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e 2182 LEAVE_SCOPE(oldsave);
936c78b5 2183 FREETMPS;
3a1b2b9e 2184 PL_curcop = cx->blk_oldcop;
a034e688 2185 return redo_op;
a0d0e21e
LW		 2186}
2187
0824fdcb 2188STATIC OP *
bfed75c6 2189S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
a0d0e21e 2190{
4ea42e7f 2191 OP *kid = Nullop;
a0d0e21e 2192 OP **ops = opstack;
bfed75c6 2193 static const char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2194
fc36a67e 2195 if (ops >= oplimit)
cea2e8a9 2196 Perl_croak(aTHX_ too_deep);
11343788
MB		 2197 if (o->op_type == OP_LEAVE ||
2198 o->op_type == OP_SCOPE ||
2199 o->op_type == OP_LEAVELOOP ||
33d34e4c 2200 o->op_type == OP_LEAVESUB ||
11343788 2201 o->op_type == OP_LEAVETRY)
fc36a67e 2202 {
5dc0d613 2203 *ops++ = cUNOPo->op_first;
fc36a67e 2204 if (ops >= oplimit)
cea2e8a9 2205 Perl_croak(aTHX_ too_deep);
fc36a67e 2206 }
c4aa4e48 2207 *ops = 0;
11343788 2208 if (o->op_flags & OPf_KIDS) {
a0d0e21e 2209 /* First try all the kids at this level, since that's likeliest. */
11343788 2210 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2211 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2212 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2213 return kid;
2214 }
11343788 2215 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2216 if (kid == PL_lastgotoprobe)
a0d0e21e 2217 continue;
ed8d0fe2
SM		 2218 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2219 if (ops == opstack)
2220 *ops++ = kid;
2221 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2222 ops[-1]->op_type == OP_DBSTATE)
2223 ops[-1] = kid;
2224 else
2225 *ops++ = kid;
2226 }
155aba94 2227 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2228 return o;
a0d0e21e
LW		 2229 }
2230 }
c4aa4e48 2231 *ops = 0;
a0d0e21e
LW		 2232 return 0;
2233}
2234
2235PP(pp_dump)
2236{
cea2e8a9 2237 return pp_goto();
a0d0e21e
LW		 2238 /*NOTREACHED*/
2239}
2240
2241PP(pp_goto)
2242{
27da23d5 2243 dVAR; dSP;
a0d0e21e
LW		 2244 OP *retop = 0;
2245 I32 ix;
c09156bb 2246 register PERL_CONTEXT *cx;
fc36a67e 2247#define GOTO_DEPTH 64
2248 OP *enterops[GOTO_DEPTH];
bfed75c6
AL		 2249 const char *label = 0;
2250 const bool do_dump = (PL_op->op_type == OP_DUMP);
2251 static const char must_have_label[] = "goto must have label";
a0d0e21e 2252
533c011a 2253 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2254 SV *sv = POPs;
2d8e6c8d 2255 STRLEN n_a;
a0d0e21e
LW		 2256
2257 /* This egregious kludge implements goto &subroutine */
2258 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2259 I32 cxix;
c09156bb 2260 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2261 CV* cv = (CV*)SvRV(sv);
2262 SV** mark;
2263 I32 items = 0;
2264 I32 oldsave;
b1464ded 2265 bool reified = 0;
a0d0e21e 2266
e8f7dd13 2267 retry:
4aa0a1f7 2268 if (!CvROOT(cv) && !CvXSUB(cv)) {
7fc63493 2269 const GV * const gv = CvGV(cv);
e8f7dd13 2270 if (gv) {
7fc63493 2271 GV *autogv;
e8f7dd13
GS		 2272 SV *tmpstr;
2273 /* autoloaded stub? */
2274 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2275 goto retry;
2276 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2277 GvNAMELEN(gv), FALSE);
2278 if (autogv && (cv = GvCV(autogv)))
2279 goto retry;
2280 tmpstr = sv_newmortal();
2281 gv_efullname3(tmpstr, gv, Nullch);
35c1215d 2282 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
4aa0a1f7 2283 }
cea2e8a9 2284 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2285 }
2286
a0d0e21e 2287 /* First do some returnish stuff. */
7fc63493 2288 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
71fc2216 2289 FREETMPS;
a0d0e21e
LW		 2290 cxix = dopoptosub(cxstack_ix);
2291 if (cxix < 0)
cea2e8a9 2292 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2293 if (cxix < cxstack_ix)
2294 dounwind(cxix);
2295 TOPBLOCK(cx);
2d43a17f 2296 SPAGAIN;
564abe23 2297 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2d43a17f 2298 if (CxTYPE(cx) == CXt_EVAL) {
c74ace89
DM		 2299 if (CxREALEVAL(cx))
2300 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2301 else
2302 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2d43a17f 2303 }
d8b46c1b
GS		 2304 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2305 /* put @_ back onto stack */
a0d0e21e 2306 AV* av = cx->blk_sub.argarray;
bfed75c6 2307
93965878 2308 items = AvFILLp(av) + 1;
a45cdc79
DM		 2309 EXTEND(SP, items+1); /* @_ could have been extended. */
2310 Copy(AvARRAY(av), SP + 1, items, SV*);
3280af22
NIS		 2311 SvREFCNT_dec(GvAV(PL_defgv));
2312 GvAV(PL_defgv) = cx->blk_sub.savearray;
b1464ded 2313 CLEAR_ARGARRAY(av);
d8b46c1b 2314 /* abandon @_ if it got reified */
62b1ebc2 2315 if (AvREAL(av)) {
b1464ded
DM		 2316 reified = 1;
2317 SvREFCNT_dec(av);
d8b46c1b
GS		 2318 av = newAV();
2319 av_extend(av, items-1);
11ca45c0 2320 AvREIFY_only(av);
dd2155a4 2321 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2322 }
a0d0e21e 2323 }
1fa4e549
AD		 2324 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2325 AV* av;
3280af22 2326 av = GvAV(PL_defgv);
1fa4e549 2327 items = AvFILLp(av) + 1;
a45cdc79
DM		 2328 EXTEND(SP, items+1); /* @_ could have been extended. */
2329 Copy(AvARRAY(av), SP + 1, items, SV*);
1fa4e549 2330 }
a45cdc79
DM		 2331 mark = SP;
2332 SP += items;
6b35e009 2333 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2334 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2335 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2336 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2337 LEAVE_SCOPE(oldsave);
2338
2339 /* Now do some callish stuff. */
2340 SAVETMPS;
5023d17a 2341 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
a0d0e21e 2342 if (CvXSUB(cv)) {
5eff7df7 2343 OP* retop = cx->blk_sub.retop;
b1464ded
DM		 2344 if (reified) {
2345 I32 index;
2346 for (index=0; index<items; index++)
2347 sv_2mortal(SP[-index]);
2348 }
67caa1fe 2349#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2350 if (CvOLDSTYLE(cv)) {
20ce7b12 2351 I32 (*fp3)(int,int,int);
924508f0
GS		 2352 while (SP > mark) {
2353 SP[1] = SP[0];
2354 SP--;
a0d0e21e 2355 }
7766f137 2356 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2357 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2358 mark - PL_stack_base + 1,
ecfc5424 2359 items);
3280af22 2360 SP = PL_stack_base + items;
a0d0e21e 2361 }
67caa1fe
GS		 2362 else
2363#endif /* PERL_XSUB_OLDSTYLE */
2364 {
1fa4e549
AD		 2365 SV **newsp;
2366 I32 gimme;
2367
5eff7df7
DM		 2368 /* XS subs don't have a CxSUB, so pop it */
2369 POPBLOCK(cx, PL_curpm);
1fa4e549 2370 /* Push a mark for the start of arglist */
ac27b0f5 2371 PUSHMARK(mark);
a45cdc79 2372 PUTBACK;
acfe0abc 2373 (void)(*CvXSUB(cv))(aTHX_ cv);
a0d0e21e
LW		 2374 }
2375 LEAVE;
5eff7df7 2376 return retop;
a0d0e21e
LW		 2377 }
2378 else {
2379 AV* padlist = CvPADLIST(cv);
6b35e009 2380 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2381 PL_in_eval = cx->blk_eval.old_in_eval;
2382 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2383 cx->cx_type = CXt_SUB;
2384 cx->blk_sub.hasargs = 0;
2385 }
a0d0e21e 2386 cx->blk_sub.cv = cv;
eb160463 2387 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
dd2155a4 2388
a0d0e21e
LW		 2389 CvDEPTH(cv)++;
2390 if (CvDEPTH(cv) < 2)
2391 (void)SvREFCNT_inc(cv);
dd2155a4 2392 else {
599cee73 2393 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2394 sub_crush_depth(cv);
26019298 2395 pad_push(padlist, CvDEPTH(cv));
a0d0e21e 2396 }
dd2155a4 2397 PAD_SET_CUR(padlist, CvDEPTH(cv));
6d4ff0d2 2398 if (cx->blk_sub.hasargs)
6d4ff0d2 2399 {
dd2155a4 2400 AV* av = (AV*)PAD_SVl(0);
a0d0e21e
LW		 2401 SV** ary;
2402
3280af22
NIS		 2403 cx->blk_sub.savearray = GvAV(PL_defgv);
2404 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
dd2155a4 2405 CX_CURPAD_SAVE(cx->blk_sub);
6d4ff0d2 2406 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2407
2408 if (items >= AvMAX(av) + 1) {
2409 ary = AvALLOC(av);
2410 if (AvARRAY(av) != ary) {
2411 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
f880fe2f 2412 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2413 }
2414 if (items >= AvMAX(av) + 1) {
2415 AvMAX(av) = items - 1;
2416 Renew(ary,items+1,SV*);
2417 AvALLOC(av) = ary;
f880fe2f 2418 SvPV_set(av, (char*)ary);
a0d0e21e
LW		 2419 }
2420 }
a45cdc79 2421 ++mark;
a0d0e21e 2422 Copy(mark,AvARRAY(av),items,SV*);
93965878 2423 AvFILLp(av) = items - 1;
d8b46c1b 2424 assert(!AvREAL(av));
b1464ded
DM		 2425 if (reified) {
2426 /* transfer 'ownership' of refcnts to new @_ */
2427 AvREAL_on(av);
2428 AvREIFY_off(av);
2429 }
a0d0e21e
LW		 2430 while (items--) {
2431 if (*mark)
2432 SvTEMP_off(*mark);
2433 mark++;
2434 }
2435 }
491527d0 2436 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2437 /*
2438 * We do not care about using sv to call CV;
2439 * it's for informational purposes only.
2440 */
3280af22 2441 SV *sv = GvSV(PL_DBsub);
491527d0 2442 CV *gotocv;
bfed75c6 2443
f398eb67 2444 save_item(sv);
491527d0 2445 if (PERLDB_SUB_NN) {
f398eb67
NC		 2446 int type = SvTYPE(sv);
2447 if (type < SVt_PVIV && type != SVt_IV)
2448 sv_upgrade(sv, SVt_PVIV);
7619c85e 2449 (void)SvIOK_on(sv);
45977657 2450 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
491527d0 2451 } else {
491527d0
GS		 2452 gv_efullname3(sv, CvGV(cv), Nullch);
2453 }
2454 if ( PERLDB_GOTO
864dbfa3 2455 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2456 PUSHMARK( PL_stack_sp );
864dbfa3 2457 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2458 PL_stack_sp--;
491527d0 2459 }
1ce6579f 2460 }
a0d0e21e
LW		 2461 RETURNOP(CvSTART(cv));
2462 }
2463 }
1614b0e3 2464 else {
2d8e6c8d 2465 label = SvPV(sv,n_a);
1614b0e3 2466 if (!(do_dump || *label))
cea2e8a9 2467 DIE(aTHX_ must_have_label);
1614b0e3 2468 }
a0d0e21e 2469 }
533c011a 2470 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2471 if (! do_dump)
cea2e8a9 2472 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2473 }
2474 else
2475 label = cPVOP->op_pv;
2476
2477 if (label && *label) {
2478 OP *gotoprobe = 0;
3b2447bc 2479 bool leaving_eval = FALSE;
33d34e4c 2480 bool in_block = FALSE;
a4f3a277 2481 PERL_CONTEXT *last_eval_cx = 0;
a0d0e21e
LW		 2482
2483 /* find label */
2484
3280af22 2485 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2486 *enterops = 0;
2487 for (ix = cxstack_ix; ix >= 0; ix--) {
2488 cx = &cxstack[ix];
6b35e009 2489 switch (CxTYPE(cx)) {
a0d0e21e 2490 case CXt_EVAL:
3b2447bc 2491 leaving_eval = TRUE;
971ecbe6 2492 if (!CxTRYBLOCK(cx)) {
a4f3a277
RH		 2493 gotoprobe = (last_eval_cx ?
2494 last_eval_cx->blk_eval.old_eval_root :
2495 PL_eval_root);
2496 last_eval_cx = cx;
9c5794fe
RH		 2497 break;
2498 }
2499 /* else fall through */
a0d0e21e
LW		 2500 case CXt_LOOP:
2501 gotoprobe = cx->blk_oldcop->op_sibling;
2502 break;
2503 case CXt_SUBST:
2504 continue;
2505 case CXt_BLOCK:
33d34e4c 2506 if (ix) {
a0d0e21e 2507 gotoprobe = cx->blk_oldcop->op_sibling;
33d34e4c
AE		 2508 in_block = TRUE;
2509 } else
3280af22 2510 gotoprobe = PL_main_root;
a0d0e21e 2511 break;
b3933176
CS		 2512 case CXt_SUB:
2513 if (CvDEPTH(cx->blk_sub.cv)) {
2514 gotoprobe = CvROOT(cx->blk_sub.cv);
2515 break;
2516 }
2517 /* FALL THROUGH */
7766f137 2518 case CXt_FORMAT:
0a753a76 2519 case CXt_NULL:
a651a37d 2520 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2521 default:
2522 if (ix)
cea2e8a9 2523 DIE(aTHX_ "panic: goto");
3280af22 2524 gotoprobe = PL_main_root;
a0d0e21e
LW		 2525 break;
2526 }
2b597662
GS		 2527 if (gotoprobe) {
2528 retop = dofindlabel(gotoprobe, label,
2529 enterops, enterops + GOTO_DEPTH);
2530 if (retop)
2531 break;
2532 }
3280af22 2533 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2534 }
2535 if (!retop)
cea2e8a9 2536 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e 2537
3b2447bc
RH		 2538 /* if we're leaving an eval, check before we pop any frames
2539 that we're not going to punt, otherwise the error
2540 won't be caught */
2541
2542 if (leaving_eval && *enterops && enterops[1]) {
2543 I32 i;
2544 for (i = 1; enterops[i]; i++)
2545 if (enterops[i]->op_type == OP_ENTERITER)
2546 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2547 }
2548
a0d0e21e
LW		 2549 /* pop unwanted frames */
2550
2551 if (ix < cxstack_ix) {
2552 I32 oldsave;
2553
2554 if (ix < 0)
2555 ix = 0;
2556 dounwind(ix);
2557 TOPBLOCK(cx);
3280af22 2558 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2559 LEAVE_SCOPE(oldsave);
2560 }
2561
2562 /* push wanted frames */
2563
748a9306 2564 if (*enterops && enterops[1]) {
533c011a 2565 OP *oldop = PL_op;
33d34e4c
AE		 2566 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2567 for (; enterops[ix]; ix++) {
533c011a 2568 PL_op = enterops[ix];
84902520
TB		 2569 /* Eventually we may want to stack the needed arguments
2570 * for each op. For now, we punt on the hard ones. */
533c011a 2571 if (PL_op->op_type == OP_ENTERITER)
894356b3 2572 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2573 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2574 }
533c011a 2575 PL_op = oldop;
a0d0e21e
LW		 2576 }
2577 }
2578
2579 if (do_dump) {
a5f75d66 2580#ifdef VMS
6b88bc9c 2581 if (!retop) retop = PL_main_start;
a5f75d66 2582#endif
3280af22
NIS		 2583 PL_restartop = retop;
2584 PL_do_undump = TRUE;
a0d0e21e
LW		 2585
2586 my_unexec();
2587
3280af22
NIS		 2588 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2589 PL_do_undump = FALSE;
a0d0e21e
LW		 2590 }
2591
2592 RETURNOP(retop);
2593}
2594
2595PP(pp_exit)
2596{
39644a26 2597 dSP;
a0d0e21e
LW		 2598 I32 anum;
2599
2600 if (MAXARG < 1)
2601 anum = 0;
ff0cee69 2602 else {
a0d0e21e 2603 anum = SvIVx(POPs);
d98f61e7
GS		 2604#ifdef VMS
2605 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2606 anum = 0;
96e176bf 2607 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
ff0cee69 2608#endif
2609 }
cc3604b1 2610 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2611 my_exit(anum);
3280af22 2612 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2613 RETURN;
2614}
2615
2616#ifdef NOTYET
2617PP(pp_nswitch)
2618{
39644a26 2619 dSP;
f54cb97a 2620 const NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2621 register I32 match = I_32(value);
2622
2623 if (value < 0.0) {
65202027 2624 if (((NV)match) > value)
a0d0e21e
LW		 2625 --match; /* was fractional--truncate other way */
2626 }
2627 match -= cCOP->uop.scop.scop_offset;
2628 if (match < 0)
2629 match = 0;
2630 else if (match > cCOP->uop.scop.scop_max)
2631 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2632 PL_op = cCOP->uop.scop.scop_next[match];
2633 RETURNOP(PL_op);
a0d0e21e
LW		 2634}
2635
2636PP(pp_cswitch)
2637{
39644a26 2638 dSP;
a0d0e21e
LW		 2639 register I32 match;
2640
6b88bc9c
GS		 2641 if (PL_multiline)
2642 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2643 else {
2d8e6c8d
GS		 2644 STRLEN n_a;
2645 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2646 match -= cCOP->uop.scop.scop_offset;
2647 if (match < 0)
2648 match = 0;
2649 else if (match > cCOP->uop.scop.scop_max)
2650 match = cCOP->uop.scop.scop_max;
6b88bc9c 2651 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2652 }
6b88bc9c 2653 RETURNOP(PL_op);
a0d0e21e
LW		 2654}
2655#endif
2656
2657/* Eval. */
2658
0824fdcb 2659STATIC void
cea2e8a9 2660S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e 2661{
504618e9
AL		 2662 const char *s = SvPVX_const(sv);
2663 const char *send = SvPVX_const(sv) + SvCUR(sv);
2664 I32 line = 1;
a0d0e21e
LW		 2665
2666 while (s && s < send) {
f54cb97a 2667 const char *t;
a0d0e21e
LW		 2668 SV *tmpstr = NEWSV(85,0);
2669
2670 sv_upgrade(tmpstr, SVt_PVMG);
2671 t = strchr(s, '\n');
2672 if (t)
2673 t++;
2674 else
2675 t = send;
2676
2677 sv_setpvn(tmpstr, s, t - s);
2678 av_store(array, line++, tmpstr);
2679 s = t;
2680 }
2681}
2682
14dd3ad8
GS		 2683STATIC void *
2684S_docatch_body(pTHX)
2685{
cea2e8a9 2686 CALLRUNOPS(aTHX);
312caa8e
CS		 2687 return NULL;
2688}
2689
0824fdcb 2690STATIC OP *
cea2e8a9 2691S_docatch(pTHX_ OP *o)
1e422769 2692{
6224f72b 2693 int ret;
06b5626a 2694 OP * const oldop = PL_op;
db36c5a1 2695 dJMPENV;
1e422769 2696
1e422769 2697#ifdef DEBUGGING
54310121 2698 assert(CATCH_GET == TRUE);
1e422769 2699#endif
312caa8e 2700 PL_op = o;
8bffa5f8 2701
14dd3ad8 2702 JMPENV_PUSH(ret);
6224f72b 2703 switch (ret) {
312caa8e 2704 case 0:
abd70938
DM		 2705 assert(cxstack_ix >= 0);
2706 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2707 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
14dd3ad8
GS		 2708 redo_body:
2709 docatch_body();
312caa8e
CS		 2710 break;
2711 case 3:
8bffa5f8 2712 /* die caught by an inner eval - continue inner loop */
abd70938
DM		 2713
2714 /* NB XXX we rely on the old popped CxEVAL still being at the top
2715 * of the stack; the way die_where() currently works, this
2716 * assumption is valid. In theory The cur_top_env value should be
2717 * returned in another global, the way retop (aka PL_restartop)
2718 * is. */
2719 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2720
2721 if (PL_restartop
2722 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2723 {
312caa8e
CS		 2724 PL_op = PL_restartop;
2725 PL_restartop = 0;
2726 goto redo_body;
2727 }
2728 /* FALL THROUGH */
2729 default:
14dd3ad8 2730 JMPENV_POP;
533c011a 2731 PL_op = oldop;
6224f72b 2732 JMPENV_JUMP(ret);
1e422769 2733 /* NOTREACHED */
1e422769 2734 }
14dd3ad8 2735 JMPENV_POP;
533c011a 2736 PL_op = oldop;
745cf2ff 2737 return Nullop;
1e422769 2738}
2739
c277df42 2740OP *
bfed75c6 2741Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
c277df42
IZ		 2742/* sv Text to convert to OP tree. */
2743/* startop op_free() this to undo. */
2744/* code Short string id of the caller. */
2745{
27da23d5 2746 dVAR; dSP; /* Make POPBLOCK work. */
c277df42
IZ		 2747 PERL_CONTEXT *cx;
2748 SV **newsp;
f987c7de 2749 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2750 I32 optype;
2751 OP dummy;
155aba94 2752 OP *rop;
83ee9e09
GS		 2753 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2754 char *tmpbuf = tbuf;
c277df42 2755 char *safestr;
a3985cdc 2756 int runtime;
40b8d195 2757 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
c277df42
IZ		 2758
2759 ENTER;
2760 lex_start(sv);
2761 SAVETMPS;
2762 /* switch to eval mode */
2763
923e4eb5 2764 if (IN_PERL_COMPILETIME) {
f4dd75d9 2765 SAVECOPSTASH_FREE(&PL_compiling);
11faa288 2766 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2767 }
83ee9e09
GS		 2768 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2769 SV *sv = sv_newmortal();
2770 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2771 code, (unsigned long)++PL_evalseq,
2772 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2773 tmpbuf = SvPVX(sv);
2774 }
2775 else
2776 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
f4dd75d9 2777 SAVECOPFILE_FREE(&PL_compiling);
57843af0 2778 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 2779 SAVECOPLINE(&PL_compiling);
57843af0 2780 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2781 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2782 deleting the eval's FILEGV from the stash before gv_check() runs
2783 (i.e. before run-time proper). To work around the coredump that
2784 ensues, we always turn GvMULTI_on for any globals that were
2785 introduced within evals. See force_ident(). GSAR 96-10-12 */
2786 safestr = savepv(tmpbuf);
3280af22 2787 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2788 SAVEHINTS();
d1ca3daa 2789#ifdef OP_IN_REGISTER
6b88bc9c 2790 PL_opsave = op;
d1ca3daa 2791#else
7766f137 2792 SAVEVPTR(PL_op);
d1ca3daa 2793#endif
c277df42 2794
a3985cdc 2795 /* we get here either during compilation, or via pp_regcomp at runtime */
923e4eb5 2796 runtime = IN_PERL_RUNTIME;
a3985cdc 2797 if (runtime)
d819b83a 2798 runcv = find_runcv(NULL);
a3985cdc 2799
533c011a 2800 PL_op = &dummy;
13b51b79 2801 PL_op->op_type = OP_ENTEREVAL;
533c011a 2802 PL_op->op_flags = 0; /* Avoid uninit warning. */
923e4eb5 2803 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
cc49e20b 2804 PUSHEVAL(cx, 0, Nullgv);
a3985cdc
DM		 2805
2806 if (runtime)
2807 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2808 else
2809 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
13b51b79 2810 POPBLOCK(cx,PL_curpm);
e84b9f1f 2811 POPEVAL(cx);
c277df42
IZ		 2812
2813 (*startop)->op_type = OP_NULL;
22c35a8c 2814 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2815 lex_end();
f3548bdc
DM		 2816 /* XXX DAPM do this properly one year */
2817 *padp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2818 LEAVE;
923e4eb5 2819 if (IN_PERL_COMPILETIME)
eb160463 2820 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
d1ca3daa 2821#ifdef OP_IN_REGISTER
6b88bc9c 2822 op = PL_opsave;
d1ca3daa 2823#endif
c277df42
IZ		 2824 return rop;
2825}
2826
a3985cdc
DM		 2827
2828/*
2829=for apidoc find_runcv
2830
2831Locate the CV corresponding to the currently executing sub or eval.
d819b83a
DM		 2832If db_seqp is non_null, skip CVs that are in the DB package and populate
2833*db_seqp with the cop sequence number at the point that the DB:: code was
2834entered. (allows debuggers to eval in the scope of the breakpoint rather
8006bbc3 2835than in in the scope of the debugger itself).
a3985cdc
DM		 2836
2837=cut
2838*/
2839
2840CV*
d819b83a 2841Perl_find_runcv(pTHX_ U32 *db_seqp)
a3985cdc 2842{
a3985cdc 2843 PERL_SI *si;
a3985cdc 2844
d819b83a
DM		 2845 if (db_seqp)
2846 *db_seqp = PL_curcop->cop_seq;
a3985cdc 2847 for (si = PL_curstackinfo; si; si = si->si_prev) {
06b5626a 2848 I32 ix;
a3985cdc 2849 for (ix = si->si_cxix; ix >= 0; ix--) {
06b5626a 2850 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
d819b83a
DM		 2851 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2852 CV *cv = cx->blk_sub.cv;
2853 /* skip DB:: code */
2854 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2855 *db_seqp = cx->blk_oldcop->cop_seq;
2856 continue;
2857 }
2858 return cv;
2859 }
a3985cdc
DM		 2860 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2861 return PL_compcv;
2862 }
2863 }
2864 return PL_main_cv;
2865}
2866
2867
2868/* Compile a require/do, an eval '', or a /(?{...})/.
2869 * In the last case, startop is non-null, and contains the address of
2870 * a pointer that should be set to the just-compiled code.
2871 * outside is the lexically enclosing CV (if any) that invoked us.
2872 */
2873
4d1ff10f 2874/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2875STATIC OP *
a3985cdc 2876S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
a0d0e21e 2877{
27da23d5 2878 dVAR; dSP;
533c011a 2879 OP *saveop = PL_op;
a0d0e21e 2880
6dc8a9e4
IZ		 2881 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2882 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2883 : EVAL_INEVAL);
a0d0e21e 2884
1ce6579f 2885 PUSHMARK(SP);
2886
3280af22
NIS		 2887 SAVESPTR(PL_compcv);
2888 PL_compcv = (CV*)NEWSV(1104,0);
2889 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2890 CvEVAL_on(PL_compcv);
2090ab20
JH		 2891 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2892 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2893
a3985cdc 2894 CvOUTSIDE_SEQ(PL_compcv) = seq;
7dafbf52 2895 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
a3985cdc 2896
dd2155a4 2897 /* set up a scratch pad */
a0d0e21e 2898
dd2155a4 2899 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2c05e328 2900
07055b4c 2901
26d9b02f 2902 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
748a9306 2903
a0d0e21e
LW		 2904 /* make sure we compile in the right package */
2905
ed094faf 2906 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2907 SAVESPTR(PL_curstash);
ed094faf 2908 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2909 }
3280af22
NIS		 2910 SAVESPTR(PL_beginav);
2911 PL_beginav = newAV();
2912 SAVEFREESV(PL_beginav);
24944567 2913 SAVEI32(PL_error_count);
a0d0e21e
LW		 2914
2915 /* try to compile it */
2916
3280af22
NIS		 2917 PL_eval_root = Nullop;
2918 PL_error_count = 0;
2919 PL_curcop = &PL_compiling;
2920 PL_curcop->cop_arybase = 0;
c277df42 2921 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2922 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2923 else
c69006e4 2924 sv_setpvn(ERRSV,"",0);
3280af22 2925 if (yyparse() || PL_error_count || !PL_eval_root) {
0c58d367 2926 SV **newsp; /* Used by POPBLOCK. */
4d8b06f1 2927 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
c277df42 2928 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2929 STRLEN n_a;
bfed75c6 2930
533c011a 2931 PL_op = saveop;
3280af22
NIS		 2932 if (PL_eval_root) {
2933 op_free(PL_eval_root);
2934 PL_eval_root = Nullop;
a0d0e21e 2935 }
3280af22 2936 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2937 if (!startop) {
3280af22 2938 POPBLOCK(cx,PL_curpm);
c277df42 2939 POPEVAL(cx);
c277df42 2940 }
a0d0e21e
LW		 2941 lex_end();
2942 LEAVE;
7a2e2cd6 2943 if (optype == OP_REQUIRE) {
b464bac0
AL		 2944 const char* const msg = SvPVx(ERRSV, n_a);
2945 const SV * const nsv = cx->blk_eval.old_namesv;
504618e9 2946 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
27bcc0a7 2947 &PL_sv_undef, 0);
5a844595
GS		 2948 DIE(aTHX_ "%sCompilation failed in require",
2949 *msg ? msg : "Unknown error\n");
2950 }
2951 else if (startop) {
06b5626a 2952 const char* msg = SvPVx(ERRSV, n_a);
c277df42 2953
3280af22 2954 POPBLOCK(cx,PL_curpm);
c277df42 2955 POPEVAL(cx);
5a844595
GS		 2956 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2957 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2958 }
9d7f88dd 2959 else {
06b5626a 2960 const char* msg = SvPVx(ERRSV, n_a);
9d7f88dd
SR		 2961 if (!*msg) {
2962 sv_setpv(ERRSV, "Compilation error");
2963 }
2964 }
a0d0e21e
LW		 2965 RETPUSHUNDEF;
2966 }
57843af0 2967 CopLINE_set(&PL_compiling, 0);
c277df42 2968 if (startop) {
3280af22 2969 *startop = PL_eval_root;
c277df42 2970 } else
3280af22 2971 SAVEFREEOP(PL_eval_root);
0c58d367
RGS		 2972
2973 /* Set the context for this new optree.
2974 * If the last op is an OP_REQUIRE, force scalar context.
2975 * Otherwise, propagate the context from the eval(). */
2976 if (PL_eval_root->op_type == OP_LEAVEEVAL
2977 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2978 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2979 == OP_REQUIRE)
2980 scalar(PL_eval_root);
2981 else if (gimme & G_VOID)
3280af22 2982 scalarvoid(PL_eval_root);
54310121 2983 else if (gimme & G_ARRAY)
3280af22 2984 list(PL_eval_root);
a0d0e21e 2985 else
3280af22 2986 scalar(PL_eval_root);
a0d0e21e
LW		 2987
2988 DEBUG_x(dump_eval());
2989
55497cff 2990 /* Register with debugger: */
84902520 2991 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2992 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2993 if (cv) {
2994 dSP;
924508f0 2995 PUSHMARK(SP);
cc49e20b 2996 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2997 PUTBACK;
864dbfa3 2998 call_sv((SV*)cv, G_DISCARD);
55497cff 2999 }
3000 }
3001
a0d0e21e
LW		 3002 /* compiled okay, so do it */
3003
3280af22
NIS		 3004 CvDEPTH(PL_compcv) = 1;
3005 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 3006 PL_op = saveop; /* The caller may need it. */
6dc8a9e4 3007 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
5dc0d613 3008
3280af22 3009 RETURNOP(PL_eval_start);
a0d0e21e
LW		 3010}
3011
a6c40364 3012STATIC PerlIO *
7925835c 3013S_doopen_pm(pTHX_ const char *name, const char *mode)
b295d113 3014{
7925835c 3015#ifndef PERL_DISABLE_PMC
f54cb97a 3016 const STRLEN namelen = strlen(name);
b295d113
TH		 3017 PerlIO *fp;
3018
7894fbab 3019 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 3020 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
06b5626a 3021 const char * const pmc = SvPV_nolen(pmcsv);
b295d113 3022 Stat_t pmstat;
a6c40364
GS		 3023 Stat_t pmcstat;
3024 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 3025 fp = PerlIO_open(name, mode);
a6c40364
GS		 3026 }
3027 else {
b295d113 3028 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 3029 pmstat.st_mtime < pmcstat.st_mtime)
3030 {
3031 fp = PerlIO_open(pmc, mode);
3032 }
3033 else {
3034 fp = PerlIO_open(name, mode);
3035 }
b295d113 3036 }
a6c40364
GS		 3037 SvREFCNT_dec(pmcsv);
3038 }
3039 else {
3040 fp = PerlIO_open(name, mode);
b295d113 3041 }
b295d113 3042 return fp;
7925835c
RGS		 3043#else
3044 return PerlIO_open(name, mode);
3045#endif /* !PERL_DISABLE_PMC */
b295d113
TH		 3046}
3047
a0d0e21e
LW		 3048PP(pp_require)
3049{
27da23d5 3050 dVAR; dSP;
c09156bb 3051 register PERL_CONTEXT *cx;
a0d0e21e 3052 SV *sv;
5c144d81 3053 const char *name;
6132ea6c 3054 STRLEN len;
5c144d81 3055 const char *tryname = Nullch;
46fc3d4c 3056 SV *namesv = Nullsv;
a0d0e21e 3057 SV** svp;
f54cb97a 3058 const I32 gimme = GIMME_V;
760ac839 3059 PerlIO *tryrsfp = 0;
bbed91b5
KF		 3060 int filter_has_file = 0;
3061 GV *filter_child_proc = 0;
3062 SV *filter_state = 0;
3063 SV *filter_sub = 0;
89ccab8c 3064 SV *hook_sv = 0;
6ec9efec
JH		 3065 SV *encoding;
3066 OP *op;
a0d0e21e
LW		 3067
3068 sv = POPs;
d7aa5382
JP		 3069 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3070 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
9014280d 3071 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
e3407aba 3072 "v-string in use/require non-portable");
d7aa5382
JP		 3073
3074 sv = new_version(sv);
3075 if (!sv_derived_from(PL_patchlevel, "version"))
3076 (void *)upg_version(PL_patchlevel);
3077 if ( vcmp(sv,PL_patchlevel) > 0 )
014ead4b 3078 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
d7aa5382
JP		 3079 vstringify(sv), vstringify(PL_patchlevel));
3080
4305d8ab 3081 RETPUSHYES;
a0d0e21e 3082 }
5c144d81 3083 name = SvPV_const(sv, len);
6132ea6c 3084 if (!(name && len > 0 && *name))
cea2e8a9 3085 DIE(aTHX_ "Null filename used");
4633a7c4 3086 TAINT_PROPER("require");
533c011a 3087 if (PL_op->op_type == OP_REQUIRE &&
27bcc0a7
RGS		 3088 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3089 if (*svp != &PL_sv_undef)
4d8b06f1
RD		 3090 RETPUSHYES;
3091 else
3092 DIE(aTHX_ "Compilation failed in require");
3093 }
a0d0e21e
LW		 3094
3095 /* prepare to compile file */
3096
be4b629d 3097 if (path_is_absolute(name)) {
46fc3d4c 3098 tryname = name;
7925835c 3099 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
bf4acbe4 3100 }
67627c52
JH		 3101#ifdef MACOS_TRADITIONAL
3102 if (!tryrsfp) {
3103 char newname[256];
3104
3105 MacPerl_CanonDir(name, newname, 1);
3106 if (path_is_absolute(newname)) {
3107 tryname = newname;
7925835c 3108 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
67627c52
JH		 3109 }
3110 }
3111#endif
be4b629d 3112 if (!tryrsfp) {
3280af22 3113 AV *ar = GvAVn(PL_incgv);
a0d0e21e 3114 I32 i;
748a9306 3115#ifdef VMS
46fc3d4c 3116 char *unixname;
3117 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3118#endif
3119 {
3120 namesv = NEWSV(806, 0);
3121 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3122 SV *dirsv = *av_fetch(ar, i, TRUE);
3123
3124 if (SvROK(dirsv)) {
3125 int count;
3126 SV *loader = dirsv;
3127
e14e2dc8
NC		 3128 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3129 && !sv_isobject(loader))
3130 {
bbed91b5
KF		 3131 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3132 }
3133
b900a521 3134 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
44f0be63 3135 PTR2UV(SvRV(dirsv)), name);
bbed91b5
KF		 3136 tryname = SvPVX(namesv);
3137 tryrsfp = 0;
3138
3139 ENTER;
3140 SAVETMPS;
3141 EXTEND(SP, 2);
3142
3143 PUSHMARK(SP);
3144 PUSHs(dirsv);
3145 PUSHs(sv);
3146 PUTBACK;
e982885c
NC		 3147 if (sv_isobject(loader))
3148 count = call_method("INC", G_ARRAY);
3149 else
3150 count = call_sv(loader, G_ARRAY);
bbed91b5
KF		 3151 SPAGAIN;
3152
3153 if (count > 0) {
3154 int i = 0;
3155 SV *arg;
3156
3157 SP -= count - 1;
3158 arg = SP[i++];
3159
3160 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3161 arg = SvRV(arg);
3162 }
3163
3164 if (SvTYPE(arg) == SVt_PVGV) {
3165 IO *io = GvIO((GV *)arg);
3166
3167 ++filter_has_file;
3168
3169 if (io) {
3170 tryrsfp = IoIFP(io);
50952442 3171 if (IoTYPE(io) == IoTYPE_PIPE) {
bbed91b5
KF		 3172 /* reading from a child process doesn't
3173 nest -- when returning from reading
3174 the inner module, the outer one is
3175 unreadable (closed?) I've tried to
3176 save the gv to manage the lifespan of
3177 the pipe, but this didn't help. XXX */
3178 filter_child_proc = (GV *)arg;
520c758a 3179 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3180 }
3181 else {
3182 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3183 PerlIO_close(IoOFP(io));
3184 }
3185 IoIFP(io) = Nullfp;
3186 IoOFP(io) = Nullfp;
3187 }
3188 }
3189
3190 if (i < count) {
3191 arg = SP[i++];
3192 }
3193 }
3194
3195 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3196 filter_sub = arg;
520c758a 3197 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3198
3199 if (i < count) {
3200 filter_state = SP[i];
520c758a 3201 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3202 }
3203
3204 if (tryrsfp == 0) {
3205 tryrsfp = PerlIO_open("/dev/null",
3206 PERL_SCRIPT_MODE);
3207 }
3208 }
1d06aecd 3209 SP--;
bbed91b5
KF		 3210 }
3211
3212 PUTBACK;
3213 FREETMPS;
3214 LEAVE;
3215
3216 if (tryrsfp) {
89ccab8c 3217 hook_sv = dirsv;
bbed91b5
KF		 3218 break;
3219 }
3220
3221 filter_has_file = 0;
3222 if (filter_child_proc) {
3223 SvREFCNT_dec(filter_child_proc);
3224 filter_child_proc = 0;
3225 }
3226 if (filter_state) {
3227 SvREFCNT_dec(filter_state);
3228 filter_state = 0;
3229 }
3230 if (filter_sub) {
3231 SvREFCNT_dec(filter_sub);
3232 filter_sub = 0;
3233 }
3234 }
3235 else {
be4b629d
CN		 3236 if (!path_is_absolute(name)
3237#ifdef MACOS_TRADITIONAL
3238 /* We consider paths of the form :a:b ambiguous and interpret them first
3239 as global then as local
3240 */
3241 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3242#endif
3243 ) {
f54cb97a 3244 STRLEN n_a;
bbed91b5 3245 char *dir = SvPVx(dirsv, n_a);
bf4acbe4 3246#ifdef MACOS_TRADITIONAL
67627c52
JH		 3247 char buf1[256];
3248 char buf2[256];
3249
3250 MacPerl_CanonDir(name, buf2, 1);
3251 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
bf4acbe4 3252#else
27da23d5 3253# ifdef VMS
bbed91b5
KF		 3254 char *unixdir;
3255 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3256 continue;
3257 sv_setpv(namesv, unixdir);
3258 sv_catpv(namesv, unixname);
27da23d5
JH		 3259# else
3260# ifdef SYMBIAN
3261 if (PL_origfilename[0] &&
3262 PL_origfilename[1] == ':' &&
3263 !(dir[0] && dir[1] == ':'))
3264 Perl_sv_setpvf(aTHX_ namesv,
3265 "%c:%s\\%s",
3266 PL_origfilename[0],
3267 dir, name);
3268 else
3269 Perl_sv_setpvf(aTHX_ namesv,
3270 "%s\\%s",
3271 dir, name);
3272# else
bbed91b5 3273 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
27da23d5
JH		 3274# endif
3275# endif
bf4acbe4 3276#endif
bbed91b5
KF		 3277 TAINT_PROPER("require");
3278 tryname = SvPVX(namesv);
7925835c 3279 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
bbed91b5
KF		 3280 if (tryrsfp) {
3281 if (tryname[0] == '.' && tryname[1] == '/')
3282 tryname += 2;
3283 break;
3284 }
be4b629d 3285 }
46fc3d4c 3286 }
a0d0e21e
LW		 3287 }
3288 }
3289 }
f4dd75d9 3290 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3291 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3292 SvREFCNT_dec(namesv);
a0d0e21e 3293 if (!tryrsfp) {
533c011a 3294 if (PL_op->op_type == OP_REQUIRE) {
5c144d81 3295 const char *msgstr = name;
ec889f3a
GS		 3296 if (namesv) { /* did we lookup @INC? */
3297 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3298 SV *dirmsgsv = NEWSV(0, 0);
3299 AV *ar = GvAVn(PL_incgv);
3300 I32 i;
3301 sv_catpvn(msg, " in @INC", 8);
b15aece3 3302 if (instr(SvPVX_const(msg), ".h "))
ec889f3a 3303 sv_catpv(msg, " (change .h to .ph maybe?)");
b15aece3 3304 if (instr(SvPVX_const(msg), ".ph "))
ec889f3a
GS		 3305 sv_catpv(msg, " (did you run h2ph?)");
3306 sv_catpv(msg, " (@INC contains:");
3307 for (i = 0; i <= AvFILL(ar); i++) {
f54cb97a
AL		 3308 STRLEN n_a;
3309 const char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3310 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3311 sv_catsv(msg, dirmsgsv);
3312 }
3313 sv_catpvn(msg, ")", 1);
3314 SvREFCNT_dec(dirmsgsv);
3315 msgstr = SvPV_nolen(msg);
2683423c 3316 }
ea071790 3317 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3318 }
3319
3320 RETPUSHUNDEF;
3321 }
d8bfb8bd 3322 else
93189314 3323 SETERRNO(0, SS_NORMAL);
a0d0e21e
LW		 3324
3325 /* Assume success here to prevent recursive requirement. */
d3a4e64e
RGS		 3326 len = strlen(name);
3327 /* Check whether a hook in @INC has already filled %INC */
3328 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3329 (void)hv_store(GvHVn(PL_incgv), name, len,
3330 (hook_sv ? SvREFCNT_inc(hook_sv)
3331 : newSVpv(CopFILE(&PL_compiling), 0)),
3332 0 );
3333 }
a0d0e21e
LW		 3334
3335 ENTER;
3336 SAVETMPS;
79cb57f6 3337 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3338 SAVEGENERICSV(PL_rsfp_filters);
3339 PL_rsfp_filters = Nullav;
e50aee73 3340
3280af22 3341 PL_rsfp = tryrsfp;
b3ac6de7 3342 SAVEHINTS();
3280af22 3343 PL_hints = 0;
7766f137 3344 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3345 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3346 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3347 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3348 PL_compiling.cop_warnings = pWARN_NONE ;
317ea90d
MS		 3349 else if (PL_taint_warn)
3350 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
ac27b0f5 3351 else
d3a7d8c7 3352 PL_compiling.cop_warnings = pWARN_STD ;
ac27b0f5
NIS		 3353 SAVESPTR(PL_compiling.cop_io);
3354 PL_compiling.cop_io = Nullsv;
a0d0e21e 3355
bbed91b5
KF		 3356 if (filter_sub || filter_child_proc) {
3357 SV *datasv = filter_add(run_user_filter, Nullsv);
3358 IoLINES(datasv) = filter_has_file;
3359 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3360 IoTOP_GV(datasv) = (GV *)filter_state;
3361 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3362 }
3363
3364 /* switch to eval mode */
a0d0e21e 3365 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3366 PUSHEVAL(cx, name, Nullgv);
f39bc417 3367 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e 3368
57843af0
GS		 3369 SAVECOPLINE(&PL_compiling);
3370 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3371
3372 PUTBACK;
6ec9efec
JH		 3373
3374 /* Store and reset encoding. */
3375 encoding = PL_encoding;
3376 PL_encoding = Nullsv;
3377
a3985cdc 3378 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
bfed75c6 3379
6ec9efec
JH		 3380 /* Restore encoding. */
3381 PL_encoding = encoding;
3382
3383 return op;
a0d0e21e
LW		 3384}
3385
3386PP(pp_dofile)
3387{
cea2e8a9 3388 return pp_require();
a0d0e21e
LW		 3389}
3390
3391PP(pp_entereval)
3392{
27da23d5 3393 dVAR; dSP;
c09156bb 3394 register PERL_CONTEXT *cx;
a0d0e21e 3395 dPOPss;
f54cb97a 3396 const I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3397 char tbuf[TYPE_DIGITS(long) + 12];
3398 char *tmpbuf = tbuf;
fc36a67e 3399 char *safestr;
a0d0e21e 3400 STRLEN len;
55497cff 3401 OP *ret;
a3985cdc 3402 CV* runcv;
d819b83a 3403 U32 seq;
a0d0e21e 3404
5c144d81 3405 if (!SvPV_const(sv,len))
a0d0e21e 3406 RETPUSHUNDEF;
748a9306 3407 TAINT_PROPER("eval");
a0d0e21e
LW		 3408
3409 ENTER;
a0d0e21e 3410 lex_start(sv);
748a9306 3411 SAVETMPS;
ac27b0f5 3412
a0d0e21e
LW		 3413 /* switch to eval mode */
3414
83ee9e09
GS		 3415 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3416 SV *sv = sv_newmortal();
3417 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3418 (unsigned long)++PL_evalseq,
3419 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3420 tmpbuf = SvPVX(sv);
3421 }
3422 else
3423 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
f4dd75d9 3424 SAVECOPFILE_FREE(&PL_compiling);
57843af0 3425 CopFILE_set(&PL_compiling, tmpbuf+2);
f4dd75d9 3426 SAVECOPLINE(&PL_compiling);
57843af0 3427 CopLINE_set(&PL_compiling, 1);
55497cff 3428 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3429 deleting the eval's FILEGV from the stash before gv_check() runs
3430 (i.e. before run-time proper). To work around the coredump that
3431 ensues, we always turn GvMULTI_on for any globals that were
3432 introduced within evals. See force_ident(). GSAR 96-10-12 */
3433 safestr = savepv(tmpbuf);
3280af22 3434 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3435 SAVEHINTS();
533c011a 3436 PL_hints = PL_op->op_targ;
7766f137 3437 SAVESPTR(PL_compiling.cop_warnings);
f0a6fc86
GS		 3438 if (specialWARN(PL_curcop->cop_warnings))
3439 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3440 else {
3441 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3442 SAVEFREESV(PL_compiling.cop_warnings);
599cee73 3443 }
ac27b0f5
NIS		 3444 SAVESPTR(PL_compiling.cop_io);
3445 if (specialCopIO(PL_curcop->cop_io))
3446 PL_compiling.cop_io = PL_curcop->cop_io;
3447 else {
3448 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3449 SAVEFREESV(PL_compiling.cop_io);
3450 }
d819b83a
DM		 3451 /* special case: an eval '' executed within the DB package gets lexically
3452 * placed in the first non-DB CV rather than the current CV - this
3453 * allows the debugger to execute code, find lexicals etc, in the
3454 * scope of the code being debugged. Passing &seq gets find_runcv
3455 * to do the dirty work for us */
3456 runcv = find_runcv(&seq);
a0d0e21e 3457
6b35e009 3458 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3459 PUSHEVAL(cx, 0, Nullgv);
f39bc417 3460 cx->blk_eval.retop = PL_op->op_next;
a0d0e21e
LW		 3461
3462 /* prepare to compile string */
3463
3280af22 3464 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3465 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3466 PUTBACK;
d819b83a 3467 ret = doeval(gimme, NULL, runcv, seq);
eb160463 3468 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
533c011a 3469 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3470 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3471 }
1e422769 3472 return DOCATCH(ret);
a0d0e21e
LW		 3473}
3474
3475PP(pp_leaveeval)
3476{
27da23d5 3477 dVAR; dSP;
a0d0e21e
LW		 3478 register SV **mark;
3479 SV **newsp;
3480 PMOP *newpm;
3481 I32 gimme;
c09156bb 3482 register PERL_CONTEXT *cx;
a0d0e21e 3483 OP *retop;
06b5626a 3484 const U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3485 I32 optype;
3486
3487 POPBLOCK(cx,newpm);
3488 POPEVAL(cx);
f39bc417 3489 retop = cx->blk_eval.retop;
a0d0e21e 3490
a1f49e72 3491 TAINT_NOT;
54310121 3492 if (gimme == G_VOID)
3493 MARK = newsp;
3494 else if (gimme == G_SCALAR)