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