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