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