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