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