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