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