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