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