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