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