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