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