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