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 rsignal(), whichsig() and do_join() to public API list
[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);
3280af22
NIS		 886 if (PL_sortstash != stash) {
887 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
888 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
889 PL_sortstash = stash;
a0d0e21e
LW		 890 }
891
3280af22
NIS		 892 SAVESPTR(GvSV(PL_firstgv));
893 SAVESPTR(GvSV(PL_secondgv));
b3933176 894
3280af22 895 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
533c011a 896 if (!(PL_op->op_flags & OPf_SPECIAL)) {
b3933176
CS		 897 cx->cx_type = CXt_SUB;
898 cx->blk_gimme = G_SCALAR;
899 PUSHSUB(cx);
900 if (!CvDEPTH(cv))
3e3baf6d 901 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
b3933176 902 }
3280af22 903 PL_sortcxix = cxstack_ix;
43481408
GS		 904
905 if (hasargs && !is_xsub) {
906 /* This is mostly copied from pp_entersub */
907 AV *av = (AV*)PL_curpad[0];
908
909#ifndef USE_THREADS
910 cx->blk_sub.savearray = GvAV(PL_defgv);
911 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
912#endif /* USE_THREADS */
913 cx->blk_sub.argarray = av;
914 }
915 qsortsv((myorigmark+1), max,
916 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
a0d0e21e 917
3280af22 918 POPBLOCK(cx,PL_curpm);
ebafeae7 919 PL_stack_sp = newsp;
d3acc0f7 920 POPSTACK;
54310121 921 CATCH_SET(oldcatch);
a0d0e21e 922 }
a0d0e21e
LW		 923 }
924 else {
925 if (max > 1) {
926 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
745d3a65 927 qsortsv(ORIGMARK+1, max,
9c007264
JH		 928 (PL_op->op_private & OPpSORT_NUMERIC)
929 ? ( (PL_op->op_private & OPpSORT_INTEGER)
0b94c7bb
GS		 930 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
931 : ( overloading ? amagic_ncmp : sv_ncmp))
9c007264
JH		 932 : ( (PL_op->op_private & OPpLOCALE)
933 ? ( overloading
0b94c7bb
GS		 934 ? amagic_cmp_locale
935 : sv_cmp_locale_static)
936 : ( overloading ? amagic_cmp : sv_cmp_static)));
9c007264
JH		 937 if (PL_op->op_private & OPpSORT_REVERSE) {
938 SV **p = ORIGMARK+1;
939 SV **q = ORIGMARK+max;
940 while (p < q) {
941 SV *tmp = *p;
942 *p++ = *q;
943 *q-- = tmp;
944 }
945 }
a0d0e21e
LW		 946 }
947 }
d0abe6c5 948 LEAVE;
3280af22 949 PL_stack_sp = ORIGMARK + max;
a0d0e21e
LW		 950 return nextop;
951}
952
953/* Range stuff. */
954
955PP(pp_range)
956{
957 if (GIMME == G_ARRAY)
1a67a97c 958 return NORMAL;
538573f7 959 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 960 return cLOGOP->op_other;
538573f7 961 else
1a67a97c 962 return NORMAL;
a0d0e21e
LW		 963}
964
965PP(pp_flip)
966{
4e35701f 967 djSP;
a0d0e21e
LW		 968
969 if (GIMME == G_ARRAY) {
1a67a97c 970 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 971 }
972 else {
973 dTOPss;
533c011a 974 SV *targ = PAD_SV(PL_op->op_targ);
a0d0e21e 975
533c011a 976 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 977 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW		 978 : SvTRUE(sv) ) {
979 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 980 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 981 sv_setiv(targ, 1);
3e3baf6d 982 SETs(targ);
a0d0e21e
LW		 983 RETURN;
984 }
985 else {
986 sv_setiv(targ, 0);
924508f0 987 SP--;
1a67a97c 988 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW		 989 }
990 }
991 sv_setpv(TARG, "");
992 SETs(targ);
993 RETURN;
994 }
995}
996
997PP(pp_flop)
998{
4e35701f 999 djSP;
a0d0e21e
LW		 1000
1001 if (GIMME == G_ARRAY) {
1002 dPOPPOPssrl;
c1ab3db2 1003 register I32 i, j;
a0d0e21e
LW		 1004 register SV *sv;
1005 I32 max;
86cb7173
HS		 1006
1007 if (SvGMAGICAL(left))
1008 mg_get(left);
1009 if (SvGMAGICAL(right))
1010 mg_get(right);
a0d0e21e 1011
4633a7c4 1012 if (SvNIOKp(left) || !SvPOKp(left) ||
39eb4040
GS		 1013 SvNIOKp(right) || !SvPOKp(right) ||
1014 (looks_like_number(left) && *SvPVX(left) != '0' &&
1015 looks_like_number(right) && *SvPVX(right) != '0'))
bbce6d69 1016 {
c1ab3db2 1017 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
d470f89e 1018 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1019 i = SvIV(left);
1020 max = SvIV(right);
bbce6d69 1021 if (max >= i) {
c1ab3db2
AK		 1022 j = max - i + 1;
1023 EXTEND_MORTAL(j);
1024 EXTEND(SP, j);
bbce6d69 1025 }
c1ab3db2
AK		 1026 else
1027 j = 0;
1028 while (j--) {
bbce6d69 1029 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1030 PUSHs(sv);
1031 }
1032 }
1033 else {
1034 SV *final = sv_mortalcopy(right);
2d8e6c8d 1035 STRLEN len, n_a;
a0d0e21e
LW		 1036 char *tmps = SvPV(final, len);
1037
1038 sv = sv_mortalcopy(left);
2d8e6c8d 1039 SvPV_force(sv,n_a);
89ea2908 1040 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1041 XPUSHs(sv);
89ea2908
GA		 1042 if (strEQ(SvPVX(sv),tmps))
1043 break;
a0d0e21e
LW		 1044 sv = sv_2mortal(newSVsv(sv));
1045 sv_inc(sv);
1046 }
a0d0e21e
LW		 1047 }
1048 }
1049 else {
1050 dTOPss;
1051 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1052 sv_inc(targ);
533c011a 1053 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1054 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW		 1055 : SvTRUE(sv) ) {
1056 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1057 sv_catpv(targ, "E0");
1058 }
1059 SETs(targ);
1060 }
1061
1062 RETURN;
1063}
1064
1065/* Control. */
1066
76e3520e 1067STATIC I32
cea2e8a9 1068S_dopoptolabel(pTHX_ char *label)
a0d0e21e 1069{
11343788 1070 dTHR;
a0d0e21e 1071 register I32 i;
c09156bb 1072 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1073
1074 for (i = cxstack_ix; i >= 0; i--) {
1075 cx = &cxstack[i];
6b35e009 1076 switch (CxTYPE(cx)) {
a0d0e21e 1077 case CXt_SUBST:
e476b1b5
GS		 1078 if (ckWARN(WARN_EXITING))
1079 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
22c35a8c 1080 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1081 break;
1082 case CXt_SUB:
e476b1b5
GS		 1083 if (ckWARN(WARN_EXITING))
1084 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
22c35a8c 1085 PL_op_name[PL_op->op_type]);
a0d0e21e 1086 break;
7766f137 1087 case CXt_FORMAT:
e476b1b5
GS		 1088 if (ckWARN(WARN_EXITING))
1089 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
7766f137
GS		 1090 PL_op_name[PL_op->op_type]);
1091 break;
a0d0e21e 1092 case CXt_EVAL:
e476b1b5
GS		 1093 if (ckWARN(WARN_EXITING))
1094 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
22c35a8c 1095 PL_op_name[PL_op->op_type]);
a0d0e21e 1096 break;
0a753a76 1097 case CXt_NULL:
e476b1b5
GS		 1098 if (ckWARN(WARN_EXITING))
1099 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
22c35a8c 1100 PL_op_name[PL_op->op_type]);
0a753a76 1101 return -1;
a0d0e21e
LW		 1102 case CXt_LOOP:
1103 if (!cx->blk_loop.label ||
1104 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1105 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1106 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1107 continue;
1108 }
cea2e8a9 1109 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1110 return i;
1111 }
1112 }
1113 return i;
1114}
1115
e50aee73 1116I32
864dbfa3 1117Perl_dowantarray(pTHX)
e50aee73 1118{
54310121 1119 I32 gimme = block_gimme();
1120 return (gimme == G_VOID) ? G_SCALAR : gimme;
1121}
1122
1123I32
864dbfa3 1124Perl_block_gimme(pTHX)
54310121 1125{
11343788 1126 dTHR;
e50aee73
AD		 1127 I32 cxix;
1128
1129 cxix = dopoptosub(cxstack_ix);
1130 if (cxix < 0)
46fc3d4c 1131 return G_VOID;
e50aee73 1132
54310121 1133 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1134 case G_VOID:
1135 return G_VOID;
54310121 1136 case G_SCALAR:
e50aee73 1137 return G_SCALAR;
54310121 1138 case G_ARRAY:
1139 return G_ARRAY;
1140 default:
cea2e8a9 1141 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1142 /* NOTREACHED */
1143 return 0;
54310121 1144 }
e50aee73
AD		 1145}
1146
76e3520e 1147STATIC I32
cea2e8a9 1148S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1149{
11343788 1150 dTHR;
2c375eb9
GS		 1151 return dopoptosub_at(cxstack, startingblock);
1152}
1153
1154STATIC I32
cea2e8a9 1155S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9
GS		 1156{
1157 dTHR;
a0d0e21e 1158 I32 i;
c09156bb 1159 register PERL_CONTEXT *cx;
a0d0e21e 1160 for (i = startingblock; i >= 0; i--) {
2c375eb9 1161 cx = &cxstk[i];
6b35e009 1162 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1163 default:
1164 continue;
1165 case CXt_EVAL:
1166 case CXt_SUB:
7766f137 1167 case CXt_FORMAT:
cea2e8a9 1168 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1169 return i;
1170 }
1171 }
1172 return i;
1173}
1174
76e3520e 1175STATIC I32
cea2e8a9 1176S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1177{
11343788 1178 dTHR;
a0d0e21e 1179 I32 i;
c09156bb 1180 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1181 for (i = startingblock; i >= 0; i--) {
1182 cx = &cxstack[i];
6b35e009 1183 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1184 default:
1185 continue;
1186 case CXt_EVAL:
cea2e8a9 1187 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1188 return i;
1189 }
1190 }
1191 return i;
1192}
1193
76e3520e 1194STATIC I32
cea2e8a9 1195S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1196{
11343788 1197 dTHR;
a0d0e21e 1198 I32 i;
c09156bb 1199 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1200 for (i = startingblock; i >= 0; i--) {
1201 cx = &cxstack[i];
6b35e009 1202 switch (CxTYPE(cx)) {
a0d0e21e 1203 case CXt_SUBST:
e476b1b5
GS		 1204 if (ckWARN(WARN_EXITING))
1205 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
22c35a8c 1206 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1207 break;
1208 case CXt_SUB:
e476b1b5
GS		 1209 if (ckWARN(WARN_EXITING))
1210 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
22c35a8c 1211 PL_op_name[PL_op->op_type]);
a0d0e21e 1212 break;
7766f137 1213 case CXt_FORMAT:
e476b1b5
GS		 1214 if (ckWARN(WARN_EXITING))
1215 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
7766f137
GS		 1216 PL_op_name[PL_op->op_type]);
1217 break;
a0d0e21e 1218 case CXt_EVAL:
e476b1b5
GS		 1219 if (ckWARN(WARN_EXITING))
1220 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
22c35a8c 1221 PL_op_name[PL_op->op_type]);
a0d0e21e 1222 break;
0a753a76 1223 case CXt_NULL:
e476b1b5
GS		 1224 if (ckWARN(WARN_EXITING))
1225 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
22c35a8c 1226 PL_op_name[PL_op->op_type]);
0a753a76 1227 return -1;
a0d0e21e 1228 case CXt_LOOP:
cea2e8a9 1229 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1230 return i;
1231 }
1232 }
1233 return i;
1234}
1235
1236void
864dbfa3 1237Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1238{
11343788 1239 dTHR;
c09156bb 1240 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1241 I32 optype;
1242
1243 while (cxstack_ix > cxix) {
b0d9ce38 1244 SV *sv;
c90c0ff4 1245 cx = &cxstack[cxstack_ix];
1246 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1247 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1248 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1249 switch (CxTYPE(cx)) {
c90c0ff4 1250 case CXt_SUBST:
1251 POPSUBST(cx);
1252 continue; /* not break */
a0d0e21e 1253 case CXt_SUB:
b0d9ce38
GS		 1254 POPSUB(cx,sv);
1255 LEAVESUB(sv);
a0d0e21e
LW		 1256 break;
1257 case CXt_EVAL:
1258 POPEVAL(cx);
1259 break;
1260 case CXt_LOOP:
1261 POPLOOP(cx);
1262 break;
0a753a76 1263 case CXt_NULL:
a0d0e21e 1264 break;
7766f137
GS		 1265 case CXt_FORMAT:
1266 POPFORMAT(cx);
1267 break;
a0d0e21e 1268 }
c90c0ff4 1269 cxstack_ix--;
a0d0e21e
LW		 1270 }
1271}
1272
067f92a0
GS		 1273/*
1274 * Closures mentioned at top level of eval cannot be referenced
1275 * again, and their presence indirectly causes a memory leak.
1276 * (Note that the fact that compcv and friends are still set here
1277 * is, AFAIK, an accident.) --Chip
1278 *
1279 * XXX need to get comppad et al from eval's cv rather than
1280 * relying on the incidental global values.
1281 */
1282STATIC void
cea2e8a9 1283S_free_closures(pTHX)
067f92a0
GS		 1284{
1285 dTHR;
1286 SV **svp = AvARRAY(PL_comppad_name);
1287 I32 ix;
1288 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1289 SV *sv = svp[ix];
1290 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1291 SvREFCNT_dec(sv);
1292 svp[ix] = &PL_sv_undef;
1293
1294 sv = PL_curpad[ix];
1295 if (CvCLONE(sv)) {
1296 SvREFCNT_dec(CvOUTSIDE(sv));
1297 CvOUTSIDE(sv) = Nullcv;
1298 }
1299 else {
1300 SvREFCNT_dec(sv);
1301 sv = NEWSV(0,0);
1302 SvPADTMP_on(sv);
1303 PL_curpad[ix] = sv;
1304 }
1305 }
1306 }
1307}
1308
5a844595
GS		 1309void
1310Perl_qerror(pTHX_ SV *err)
1311{
1312 if (PL_in_eval)
1313 sv_catsv(ERRSV, err);
1314 else if (PL_errors)
1315 sv_catsv(PL_errors, err);
1316 else
894356b3 1317 Perl_warn(aTHX_ "%"SVf, err);
5a844595
GS		 1318 ++PL_error_count;
1319}
1320
a0d0e21e 1321OP *
864dbfa3 1322Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1323{
2d8e6c8d 1324 STRLEN n_a;
3280af22 1325 if (PL_in_eval) {
a0d0e21e 1326 I32 cxix;
c09156bb 1327 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1328 I32 gimme;
1329 SV **newsp;
1330
4e6ea2c3 1331 if (message) {
faef0170 1332 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS		 1333 static char prefix[] = "\t(in cleanup) ";
1334 SV *err = ERRSV;
1335 char *e = Nullch;
1336 if (!SvPOK(err))
1337 sv_setpv(err,"");
1338 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1339 e = SvPV(err, n_a);
1340 e += n_a - msglen;
1341 if (*e != *message || strNE(e,message))
1342 e = Nullch;
1343 }
1344 if (!e) {
1345 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1346 sv_catpvn(err, prefix, sizeof(prefix)-1);
1347 sv_catpvn(err, message, msglen);
e476b1b5 1348 if (ckWARN(WARN_MISC)) {
98eae8f5 1349 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
e476b1b5 1350 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
4e6ea2c3 1351 }
4633a7c4 1352 }
4633a7c4 1353 }
4e6ea2c3 1354 else
06bf62c7 1355 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW		 1356 }
1357 else
06bf62c7 1358 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1359
5a844595
GS		 1360 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1361 && PL_curstackinfo->si_prev)
1362 {
bac4b2ad 1363 dounwind(-1);
d3acc0f7 1364 POPSTACK;
bac4b2ad 1365 }
e336de0d 1366
a0d0e21e
LW		 1367 if (cxix >= 0) {
1368 I32 optype;
1369
1370 if (cxix < cxstack_ix)
1371 dounwind(cxix);
1372
3280af22 1373 POPBLOCK(cx,PL_curpm);
6b35e009 1374 if (CxTYPE(cx) != CXt_EVAL) {
bf49b057
GS		 1375 PerlIO_write(Perl_error_log, "panic: die ", 11);
1376 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1377 my_exit(1);
1378 }
1379 POPEVAL(cx);
1380
1381 if (gimme == G_SCALAR)
3280af22
NIS		 1382 *++newsp = &PL_sv_undef;
1383 PL_stack_sp = newsp;
a0d0e21e
LW		 1384
1385 LEAVE;
748a9306 1386
7a2e2cd6 1387 if (optype == OP_REQUIRE) {
2d8e6c8d 1388 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 1389 DIE(aTHX_ "%sCompilation failed in require",
1390 *msg ? msg : "Unknown error\n");
7a2e2cd6 1391 }
a0d0e21e
LW		 1392 return pop_return();
1393 }
1394 }
9cc2fdd3 1395 if (!message)
06bf62c7 1396 message = SvPVx(ERRSV, msglen);
d175a3f0
GS		 1397 {
1398#ifdef USE_SFIO
1399 /* SFIO can really mess with your errno */
1400 int e = errno;
1401#endif
bf49b057
GS		 1402 PerlIO *serr = Perl_error_log;
1403
1404 PerlIO_write(serr, message, msglen);
1405 (void)PerlIO_flush(serr);
d175a3f0
GS		 1406#ifdef USE_SFIO
1407 errno = e;
1408#endif
1409 }
f86702cc 1410 my_failure_exit();
1411 /* NOTREACHED */
a0d0e21e
LW		 1412 return 0;
1413}
1414
1415PP(pp_xor)
1416{
4e35701f 1417 djSP; dPOPTOPssrl;
a0d0e21e
LW		 1418 if (SvTRUE(left) != SvTRUE(right))
1419 RETSETYES;
1420 else
1421 RETSETNO;
1422}
1423
1424PP(pp_andassign)
1425{
4e35701f 1426 djSP;
a0d0e21e
LW		 1427 if (!SvTRUE(TOPs))
1428 RETURN;
1429 else
1430 RETURNOP(cLOGOP->op_other);
1431}
1432
1433PP(pp_orassign)
1434{
4e35701f 1435 djSP;
a0d0e21e
LW		 1436 if (SvTRUE(TOPs))
1437 RETURN;
1438 else
1439 RETURNOP(cLOGOP->op_other);
1440}
1441
a0d0e21e
LW		 1442PP(pp_caller)
1443{
4e35701f 1444 djSP;
a0d0e21e 1445 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1446 register PERL_CONTEXT *cx;
2c375eb9 1447 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1448 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1449 I32 dbcxix;
54310121 1450 I32 gimme;
ed094faf 1451 char *stashname;
a0d0e21e
LW		 1452 SV *sv;
1453 I32 count = 0;
1454
1455 if (MAXARG)
1456 count = POPi;
e476b1b5 1457 EXTEND(SP, 10);
a0d0e21e 1458 for (;;) {
2c375eb9
GS		 1459 /* we may be in a higher stacklevel, so dig down deeper */
1460 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1461 top_si = top_si->si_prev;
1462 ccstack = top_si->si_cxstack;
1463 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1464 }
a0d0e21e
LW		 1465 if (cxix < 0) {
1466 if (GIMME != G_ARRAY)
1467 RETPUSHUNDEF;
1468 RETURN;
1469 }
3280af22
NIS		 1470 if (PL_DBsub && cxix >= 0 &&
1471 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1472 count++;
1473 if (!count--)
1474 break;
2c375eb9 1475 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1476 }
2c375eb9
GS		 1477
1478 cx = &ccstack[cxix];
7766f137 1479 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2c375eb9
GS		 1480 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1481 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1482 field below is defined for any cx. */
3280af22 1483 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1484 cx = &ccstack[dbcxix];
06a5b730 1485 }
1486
ed094faf 1487 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1488 if (GIMME != G_ARRAY) {
ed094faf 1489 if (!stashname)
3280af22 1490 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1491 else {
1492 dTARGET;
ed094faf 1493 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1494 PUSHs(TARG);
1495 }
a0d0e21e
LW		 1496 RETURN;
1497 }
a0d0e21e 1498
ed094faf 1499 if (!stashname)
3280af22 1500 PUSHs(&PL_sv_undef);
49d8d3a1 1501 else
ed094faf
GS		 1502 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1503 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
57843af0 1504 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1505 if (!MAXARG)
1506 RETURN;
7766f137
GS		 1507 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1508 /* So is ccstack[dbcxix]. */
a0d0e21e 1509 sv = NEWSV(49, 0);
2c375eb9 1510 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW		 1511 PUSHs(sv_2mortal(sv));
1512 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1513 }
1514 else {
79cb57f6 1515 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1516 PUSHs(sv_2mortal(newSViv(0)));
1517 }
54310121 1518 gimme = (I32)cx->blk_gimme;
1519 if (gimme == G_VOID)
3280af22 1520 PUSHs(&PL_sv_undef);
54310121 1521 else
1522 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1523 if (CxTYPE(cx) == CXt_EVAL) {
811a4de9 1524 /* eval STRING */
06a5b730 1525 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1526 PUSHs(cx->blk_eval.cur_text);
3280af22 1527 PUSHs(&PL_sv_no);
0f79a09d 1528 }
811a4de9 1529 /* require */
0f79a09d
GS		 1530 else if (cx->blk_eval.old_namesv) {
1531 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
3280af22 1532 PUSHs(&PL_sv_yes);
06a5b730 1533 }
811a4de9
GS		 1534 /* eval BLOCK (try blocks have old_namesv == 0) */
1535 else {
1536 PUSHs(&PL_sv_undef);
1537 PUSHs(&PL_sv_undef);
1538 }
4633a7c4 1539 }
a682de96
GS		 1540 else {
1541 PUSHs(&PL_sv_undef);
1542 PUSHs(&PL_sv_undef);
1543 }
1544 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1545 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1546 {
a0d0e21e
LW		 1547 AV *ary = cx->blk_sub.argarray;
1548 int off = AvARRAY(ary) - AvALLOC(ary);
1549
3280af22 1550 if (!PL_dbargs) {
a0d0e21e 1551 GV* tmpgv;
3280af22 1552 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1553 SVt_PVAV)));
a5f75d66 1554 GvMULTI_on(tmpgv);
3280af22 1555 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW		 1556 }
1557
3280af22
NIS		 1558 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1559 av_extend(PL_dbargs, AvFILLp(ary) + off);
1560 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1561 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1562 }
f3aa04c2
GS		 1563 /* XXX only hints propagated via op_private are currently
1564 * visible (others are not easily accessible, since they
1565 * use the global PL_hints) */
1566 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1567 HINT_PRIVATE_MASK)));
e476b1b5
GS		 1568 {
1569 SV * mask ;
1570 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
d3a7d8c7 1571 if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD)
e476b1b5 1572 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
d3a7d8c7 1573 else if (old_warnings == pWARN_ALL)
e476b1b5
GS		 1574 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1575 else
1576 mask = newSVsv(old_warnings);
1577 PUSHs(sv_2mortal(mask));
1578 }
a0d0e21e
LW		 1579 RETURN;
1580}
1581
a0d0e21e
LW		 1582PP(pp_reset)
1583{
4e35701f 1584 djSP;
a0d0e21e 1585 char *tmps;
2d8e6c8d 1586 STRLEN n_a;
a0d0e21e
LW		 1587
1588 if (MAXARG < 1)
1589 tmps = "";
1590 else
2d8e6c8d 1591 tmps = POPpx;
11faa288 1592 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1593 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1594 RETURN;
1595}
1596
1597PP(pp_lineseq)
1598{
1599 return NORMAL;
1600}
1601
1602PP(pp_dbstate)
1603{
533c011a 1604 PL_curcop = (COP*)PL_op;
a0d0e21e 1605 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1606 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1607 FREETMPS;
1608
533c011a 1609 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1610 {
924508f0 1611 djSP;
a0d0e21e 1612 register CV *cv;
c09156bb 1613 register PERL_CONTEXT *cx;
748a9306 1614 I32 gimme = G_ARRAY;
a0d0e21e
LW		 1615 I32 hasargs;
1616 GV *gv;
1617
3280af22 1618 gv = PL_DBgv;
a0d0e21e 1619 cv = GvCV(gv);
a0d0e21e 1620 if (!cv)
cea2e8a9 1621 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1622
3280af22 1623 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1624 return NORMAL;
748a9306 1625
4633a7c4
LW		 1626 ENTER;
1627 SAVETMPS;
1628
3280af22 1629 SAVEI32(PL_debug);
55497cff 1630 SAVESTACK_POS();
3280af22 1631 PL_debug = 0;
748a9306 1632 hasargs = 0;
924508f0 1633 SPAGAIN;
748a9306 1634
533c011a 1635 push_return(PL_op->op_next);
924508f0 1636 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW		 1637 PUSHSUB(cx);
1638 CvDEPTH(cv)++;
1639 (void)SvREFCNT_inc(cv);
7766f137 1640 SAVEVPTR(PL_curpad);
3280af22 1641 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW		 1642 RETURNOP(CvSTART(cv));
1643 }
1644 else
1645 return NORMAL;
1646}
1647
1648PP(pp_scope)
1649{
1650 return NORMAL;
1651}
1652
1653PP(pp_enteriter)
1654{
4e35701f 1655 djSP; dMARK;
c09156bb 1656 register PERL_CONTEXT *cx;
54310121 1657 I32 gimme = GIMME_V;
a0d0e21e 1658 SV **svp;
7766f137
GS		 1659 U32 cxtype = CXt_LOOP;
1660#ifdef USE_ITHREADS
1661 void *iterdata;
1662#endif
a0d0e21e 1663
4633a7c4
LW		 1664 ENTER;
1665 SAVETMPS;
1666
54b9620d 1667#ifdef USE_THREADS
0214ae40
GS		 1668 if (PL_op->op_flags & OPf_SPECIAL) {
1669 dTHR;
1670 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1671 SAVEGENERICSV(*svp);
1672 *svp = NEWSV(0,0);
1673 }
a0d0e21e 1674 else
54b9620d 1675#endif /* USE_THREADS */
533c011a
NIS		 1676 if (PL_op->op_targ) {
1677 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d 1678 SAVESPTR(*svp);
7766f137
GS		 1679#ifdef USE_ITHREADS
1680 iterdata = (void*)PL_op->op_targ;
1681 cxtype |= CXp_PADVAR;
1682#endif
54b9620d
MB		 1683 }
1684 else {
7766f137
GS		 1685 GV *gv = (GV*)POPs;
1686 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS		 1687 SAVEGENERICSV(*svp);
1688 *svp = NEWSV(0,0);
7766f137
GS		 1689#ifdef USE_ITHREADS
1690 iterdata = (void*)gv;
1691#endif
54b9620d 1692 }
4633a7c4 1693
a0d0e21e
LW		 1694 ENTER;
1695
7766f137
GS		 1696 PUSHBLOCK(cx, cxtype, SP);
1697#ifdef USE_ITHREADS
1698 PUSHLOOP(cx, iterdata, MARK);
1699#else
a0d0e21e 1700 PUSHLOOP(cx, svp, MARK);
7766f137 1701#endif
533c011a 1702 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1703 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1704 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1705 dPOPss;
1706 if (SvNIOKp(sv) || !SvPOKp(sv) ||
39eb4040
GS		 1707 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1708 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1709 looks_like_number((SV*)cx->blk_loop.iterary) &&
1710 *SvPVX(cx->blk_loop.iterary) != '0'))
1711 {
89ea2908
GA		 1712 if (SvNV(sv) < IV_MIN ||
1713 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
d470f89e 1714 DIE(aTHX_ "Range iterator outside integer range");
89ea2908
GA		 1715 cx->blk_loop.iterix = SvIV(sv);
1716 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1717 }
1718 else
1719 cx->blk_loop.iterlval = newSVsv(sv);
1720 }
1721 }
4633a7c4 1722 else {
3280af22
NIS		 1723 cx->blk_loop.iterary = PL_curstack;
1724 AvFILLp(PL_curstack) = SP - PL_stack_base;
1725 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1726 }
a0d0e21e
LW		 1727
1728 RETURN;
1729}
1730
1731PP(pp_enterloop)
1732{
4e35701f 1733 djSP;
c09156bb 1734 register PERL_CONTEXT *cx;
54310121 1735 I32 gimme = GIMME_V;
a0d0e21e
LW		 1736
1737 ENTER;
1738 SAVETMPS;
1739 ENTER;
1740
1741 PUSHBLOCK(cx, CXt_LOOP, SP);
1742 PUSHLOOP(cx, 0, SP);
1743
1744 RETURN;
1745}
1746
1747PP(pp_leaveloop)
1748{
4e35701f 1749 djSP;
c09156bb 1750 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1751 I32 gimme;
1752 SV **newsp;
1753 PMOP *newpm;
1754 SV **mark;
1755
1756 POPBLOCK(cx,newpm);
4fdae800 1757 mark = newsp;
a8bba7fa 1758 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1759
a1f49e72 1760 TAINT_NOT;
54310121 1761 if (gimme == G_VOID)
1762 ; /* do nothing */
1763 else if (gimme == G_SCALAR) {
1764 if (mark < SP)
1765 *++newsp = sv_mortalcopy(*SP);
1766 else
3280af22 1767 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1768 }
1769 else {
a1f49e72 1770 while (mark < SP) {
a0d0e21e 1771 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1772 TAINT_NOT; /* Each item is independent */
1773 }
a0d0e21e 1774 }
f86702cc 1775 SP = newsp;
1776 PUTBACK;
1777
a8bba7fa 1778 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1779 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1780
a0d0e21e
LW		 1781 LEAVE;
1782 LEAVE;
1783
f86702cc 1784 return NORMAL;
a0d0e21e
LW		 1785}
1786
1787PP(pp_return)
1788{
4e35701f 1789 djSP; dMARK;
a0d0e21e 1790 I32 cxix;
c09156bb 1791 register PERL_CONTEXT *cx;
f86702cc 1792 bool popsub2 = FALSE;
b45de488 1793 bool clear_errsv = FALSE;
a0d0e21e
LW		 1794 I32 gimme;
1795 SV **newsp;
1796 PMOP *newpm;
1797 I32 optype = 0;
b0d9ce38 1798 SV *sv;
a0d0e21e 1799
3280af22 1800 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS		 1801 if (cxstack_ix == PL_sortcxix
1802 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1803 {
3280af22
NIS		 1804 if (cxstack_ix > PL_sortcxix)
1805 dounwind(PL_sortcxix);
1806 AvARRAY(PL_curstack)[1] = *SP;
1807 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1808 return 0;
1809 }
1810 }
1811
1812 cxix = dopoptosub(cxstack_ix);
1813 if (cxix < 0)
cea2e8a9 1814 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1815 if (cxix < cxstack_ix)
1816 dounwind(cxix);
1817
1818 POPBLOCK(cx,newpm);
6b35e009 1819 switch (CxTYPE(cx)) {
a0d0e21e 1820 case CXt_SUB:
f86702cc 1821 popsub2 = TRUE;
a0d0e21e
LW		 1822 break;
1823 case CXt_EVAL:
b45de488
GS		 1824 if (!(PL_in_eval & EVAL_KEEPERR))
1825 clear_errsv = TRUE;
a0d0e21e 1826 POPEVAL(cx);
1d76a5c3
GS		 1827 if (CxTRYBLOCK(cx))
1828 break;
067f92a0
GS		 1829 if (AvFILLp(PL_comppad_name) >= 0)
1830 free_closures();
1831 lex_end();
748a9306
LW		 1832 if (optype == OP_REQUIRE &&
1833 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1834 {
54310121 1835 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 1836 SV *nsv = cx->blk_eval.old_namesv;
1837 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1838 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
748a9306 1839 }
a0d0e21e 1840 break;
7766f137
GS		 1841 case CXt_FORMAT:
1842 POPFORMAT(cx);
1843 break;
a0d0e21e 1844 default:
cea2e8a9 1845 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1846 }
1847
a1f49e72 1848 TAINT_NOT;
a0d0e21e 1849 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1850 if (MARK < SP) {
1851 if (popsub2) {
a8bba7fa 1852 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 1853 if (SvTEMP(TOPs)) {
1854 *++newsp = SvREFCNT_inc(*SP);
1855 FREETMPS;
1856 sv_2mortal(*newsp);
959e3673
GS		 1857 }
1858 else {
1859 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
a29cdaf0 1860 FREETMPS;
959e3673
GS		 1861 *++newsp = sv_mortalcopy(sv);
1862 SvREFCNT_dec(sv);
a29cdaf0 1863 }
959e3673
GS		 1864 }
1865 else
a29cdaf0 1866 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
959e3673
GS		 1867 }
1868 else
a29cdaf0 1869 *++newsp = sv_mortalcopy(*SP);
959e3673
GS		 1870 }
1871 else
3280af22 1872 *++newsp = &PL_sv_undef;
a0d0e21e 1873 }
54310121 1874 else if (gimme == G_ARRAY) {
a1f49e72 1875 while (++MARK <= SP) {
f86702cc 1876 *++newsp = (popsub2 && SvTEMP(*MARK))
1877 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1878 TAINT_NOT; /* Each item is independent */
1879 }
a0d0e21e 1880 }
3280af22 1881 PL_stack_sp = newsp;
a0d0e21e 1882
f86702cc 1883 /* Stack values are safe: */
1884 if (popsub2) {
b0d9ce38 1885 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1886 }
b0d9ce38
GS		 1887 else
1888 sv = Nullsv;
3280af22 1889 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1890
a0d0e21e 1891 LEAVE;
b0d9ce38 1892 LEAVESUB(sv);
b45de488
GS		 1893 if (clear_errsv)
1894 sv_setpv(ERRSV,"");
a0d0e21e
LW		 1895 return pop_return();
1896}
1897
1898PP(pp_last)
1899{
4e35701f 1900 djSP;
a0d0e21e 1901 I32 cxix;
c09156bb 1902 register PERL_CONTEXT *cx;
f86702cc 1903 I32 pop2 = 0;
a0d0e21e
LW		 1904 I32 gimme;
1905 I32 optype;
1906 OP *nextop;
1907 SV **newsp;
1908 PMOP *newpm;
a8bba7fa 1909 SV **mark;
b0d9ce38 1910 SV *sv = Nullsv;
a0d0e21e 1911
533c011a 1912 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1913 cxix = dopoptoloop(cxstack_ix);
1914 if (cxix < 0)
a651a37d 1915 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 1916 }
1917 else {
1918 cxix = dopoptolabel(cPVOP->op_pv);
1919 if (cxix < 0)
cea2e8a9 1920 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1921 }
1922 if (cxix < cxstack_ix)
1923 dounwind(cxix);
1924
1925 POPBLOCK(cx,newpm);
a8bba7fa 1926 mark = newsp;
6b35e009 1927 switch (CxTYPE(cx)) {
a0d0e21e 1928 case CXt_LOOP:
f86702cc 1929 pop2 = CXt_LOOP;
a8bba7fa
GS		 1930 newsp = PL_stack_base + cx->blk_loop.resetsp;
1931 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1932 break;
f86702cc 1933 case CXt_SUB:
f86702cc 1934 pop2 = CXt_SUB;
a0d0e21e
LW		 1935 nextop = pop_return();
1936 break;
f86702cc 1937 case CXt_EVAL:
1938 POPEVAL(cx);
a0d0e21e
LW		 1939 nextop = pop_return();
1940 break;
7766f137
GS		 1941 case CXt_FORMAT:
1942 POPFORMAT(cx);
1943 nextop = pop_return();
1944 break;
a0d0e21e 1945 default:
cea2e8a9 1946 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 1947 }
1948
a1f49e72 1949 TAINT_NOT;
a0d0e21e 1950 if (gimme == G_SCALAR) {
f86702cc 1951 if (MARK < SP)
1952 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1953 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1954 else
3280af22 1955 *++newsp = &PL_sv_undef;
a0d0e21e 1956 }
54310121 1957 else if (gimme == G_ARRAY) {
a1f49e72 1958 while (++MARK <= SP) {
f86702cc 1959 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1960 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1961 TAINT_NOT; /* Each item is independent */
1962 }
f86702cc 1963 }
1964 SP = newsp;
1965 PUTBACK;
1966
1967 /* Stack values are safe: */
1968 switch (pop2) {
1969 case CXt_LOOP:
a8bba7fa 1970 POPLOOP(cx); /* release loop vars ... */
4fdae800 1971 LEAVE;
f86702cc 1972 break;
1973 case CXt_SUB:
b0d9ce38 1974 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1975 break;
a0d0e21e 1976 }
3280af22 1977 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1978
1979 LEAVE;
b0d9ce38 1980 LEAVESUB(sv);
f86702cc 1981 return nextop;
a0d0e21e
LW		 1982}
1983
1984PP(pp_next)
1985{
1986 I32 cxix;
c09156bb 1987 register PERL_CONTEXT *cx;
85538317 1988 I32 inner;
a0d0e21e 1989
533c011a 1990 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1991 cxix = dopoptoloop(cxstack_ix);
1992 if (cxix < 0)
a651a37d 1993 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 1994 }
1995 else {
1996 cxix = dopoptolabel(cPVOP->op_pv);
1997 if (cxix < 0)
cea2e8a9 1998 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1999 }
2000 if (cxix < cxstack_ix)
2001 dounwind(cxix);
2002
85538317
GS		 2003 /* clear off anything above the scope we're re-entering, but
2004 * save the rest until after a possible continue block */
2005 inner = PL_scopestack_ix;
1ba6ee2b 2006 TOPBLOCK(cx);
85538317
GS		 2007 if (PL_scopestack_ix < inner)
2008 leave_scope(PL_scopestack[PL_scopestack_ix]);
1ba6ee2b 2009 return cx->blk_loop.next_op;
a0d0e21e
LW		 2010}
2011
2012PP(pp_redo)
2013{
2014 I32 cxix;
c09156bb 2015 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2016 I32 oldsave;
2017
533c011a 2018 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2019 cxix = dopoptoloop(cxstack_ix);
2020 if (cxix < 0)
a651a37d 2021 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2022 }
2023 else {
2024 cxix = dopoptolabel(cPVOP->op_pv);
2025 if (cxix < 0)
cea2e8a9 2026 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2027 }
2028 if (cxix < cxstack_ix)
2029 dounwind(cxix);
2030
2031 TOPBLOCK(cx);
3280af22 2032 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2033 LEAVE_SCOPE(oldsave);
2034 return cx->blk_loop.redo_op;
2035}
2036
0824fdcb 2037STATIC OP *
cea2e8a9 2038S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 2039{
2040 OP *kid;
2041 OP **ops = opstack;
fc36a67e 2042 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2043
fc36a67e 2044 if (ops >= oplimit)
cea2e8a9 2045 Perl_croak(aTHX_ too_deep);
11343788
MB		 2046 if (o->op_type == OP_LEAVE ||
2047 o->op_type == OP_SCOPE ||
2048 o->op_type == OP_LEAVELOOP ||
2049 o->op_type == OP_LEAVETRY)
fc36a67e 2050 {
5dc0d613 2051 *ops++ = cUNOPo->op_first;
fc36a67e 2052 if (ops >= oplimit)
cea2e8a9 2053 Perl_croak(aTHX_ too_deep);
fc36a67e 2054 }
c4aa4e48 2055 *ops = 0;
11343788 2056 if (o->op_flags & OPf_KIDS) {
5c0ca799 2057 dTHR;
a0d0e21e 2058 /* First try all the kids at this level, since that's likeliest. */
11343788 2059 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2060 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2061 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2062 return kid;
2063 }
11343788 2064 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2065 if (kid == PL_lastgotoprobe)
a0d0e21e 2066 continue;
c4aa4e48
GS		 2067 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2068 (ops == opstack ||
2069 (ops[-1]->op_type != OP_NEXTSTATE &&
2070 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 2071 *ops++ = kid;
155aba94 2072 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2073 return o;
a0d0e21e
LW		 2074 }
2075 }
c4aa4e48 2076 *ops = 0;
a0d0e21e
LW		 2077 return 0;
2078}
2079
2080PP(pp_dump)
2081{
cea2e8a9 2082 return pp_goto();
a0d0e21e
LW		 2083 /*NOTREACHED*/
2084}
2085
2086PP(pp_goto)
2087{
4e35701f 2088 djSP;
a0d0e21e
LW		 2089 OP *retop = 0;
2090 I32 ix;
c09156bb 2091 register PERL_CONTEXT *cx;
fc36a67e 2092#define GOTO_DEPTH 64
2093 OP *enterops[GOTO_DEPTH];
a0d0e21e 2094 char *label;
533c011a 2095 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2096 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 2097
2098 label = 0;
533c011a 2099 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2100 SV *sv = POPs;
2d8e6c8d 2101 STRLEN n_a;
a0d0e21e
LW		 2102
2103 /* This egregious kludge implements goto &subroutine */
2104 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2105 I32 cxix;
c09156bb 2106 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2107 CV* cv = (CV*)SvRV(sv);
2108 SV** mark;
2109 I32 items = 0;
2110 I32 oldsave;
2111
e8f7dd13 2112 retry:
4aa0a1f7 2113 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 2114 GV *gv = CvGV(cv);
2115 GV *autogv;
2116 if (gv) {
2117 SV *tmpstr;
2118 /* autoloaded stub? */
2119 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2120 goto retry;
2121 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2122 GvNAMELEN(gv), FALSE);
2123 if (autogv && (cv = GvCV(autogv)))
2124 goto retry;
2125 tmpstr = sv_newmortal();
2126 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2127 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2128 }
cea2e8a9 2129 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2130 }
2131
a0d0e21e
LW		 2132 /* First do some returnish stuff. */
2133 cxix = dopoptosub(cxstack_ix);
2134 if (cxix < 0)
cea2e8a9 2135 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2136 if (cxix < cxstack_ix)
2137 dounwind(cxix);
2138 TOPBLOCK(cx);
6b35e009 2139 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2140 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2141 mark = PL_stack_sp;
d8b46c1b
GS		 2142 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2143 /* put @_ back onto stack */
a0d0e21e
LW		 2144 AV* av = cx->blk_sub.argarray;
2145
93965878 2146 items = AvFILLp(av) + 1;
3280af22
NIS		 2147 PL_stack_sp++;
2148 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2149 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2150 PL_stack_sp += items;
6d4ff0d2 2151#ifndef USE_THREADS
3280af22
NIS		 2152 SvREFCNT_dec(GvAV(PL_defgv));
2153 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2154#endif /* USE_THREADS */
d8b46c1b 2155 /* abandon @_ if it got reified */
62b1ebc2 2156 if (AvREAL(av)) {
d8b46c1b
GS		 2157 (void)sv_2mortal((SV*)av); /* delay until return */
2158 av = newAV();
2159 av_extend(av, items-1);
2160 AvFLAGS(av) = AVf_REIFY;
2161 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2162 }
a0d0e21e 2163 }
1fa4e549
AD		 2164 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2165 AV* av;
1fa4e549 2166#ifdef USE_THREADS
533c011a 2167 av = (AV*)PL_curpad[0];
1fa4e549 2168#else
3280af22 2169 av = GvAV(PL_defgv);
1fa4e549
AD		 2170#endif
2171 items = AvFILLp(av) + 1;
3280af22
NIS		 2172 PL_stack_sp++;
2173 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2174 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2175 PL_stack_sp += items;
1fa4e549 2176 }
6b35e009 2177 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2178 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2179 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2180 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2181 LEAVE_SCOPE(oldsave);
2182
2183 /* Now do some callish stuff. */
2184 SAVETMPS;
2185 if (CvXSUB(cv)) {
67caa1fe 2186#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2187 if (CvOLDSTYLE(cv)) {
20ce7b12 2188 I32 (*fp3)(int,int,int);
924508f0
GS		 2189 while (SP > mark) {
2190 SP[1] = SP[0];
2191 SP--;
a0d0e21e 2192 }
7766f137 2193 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2194 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2195 mark - PL_stack_base + 1,
ecfc5424 2196 items);
3280af22 2197 SP = PL_stack_base + items;
a0d0e21e 2198 }
67caa1fe
GS		 2199 else
2200#endif /* PERL_XSUB_OLDSTYLE */
2201 {
1fa4e549
AD		 2202 SV **newsp;
2203 I32 gimme;
2204
3280af22 2205 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 2206 /* Push a mark for the start of arglist */
2207 PUSHMARK(mark);
0cb96387 2208 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2209 /* Pop the current context like a decent sub should */
3280af22 2210 POPBLOCK(cx, PL_curpm);
1fa4e549 2211 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2212 }
2213 LEAVE;
2214 return pop_return();
2215 }
2216 else {
2217 AV* padlist = CvPADLIST(cv);
2218 SV** svp = AvARRAY(padlist);
6b35e009 2219 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2220 PL_in_eval = cx->blk_eval.old_in_eval;
2221 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2222 cx->cx_type = CXt_SUB;
2223 cx->blk_sub.hasargs = 0;
2224 }
a0d0e21e
LW		 2225 cx->blk_sub.cv = cv;
2226 cx->blk_sub.olddepth = CvDEPTH(cv);
2227 CvDEPTH(cv)++;
2228 if (CvDEPTH(cv) < 2)
2229 (void)SvREFCNT_inc(cv);
2230 else { /* save temporaries on recursion? */
599cee73 2231 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2232 sub_crush_depth(cv);
93965878 2233 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2234 AV *newpad = newAV();
4aa0a1f7 2235 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2236 I32 ix = AvFILLp((AV*)svp[1]);
7766f137 2237 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2238 svp = AvARRAY(svp[0]);
748a9306 2239 for ( ;ix > 0; ix--) {
7766f137 2240 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2241 char *name = SvPVX(svp[ix]);
5f05dabc 2242 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2243 || *name == '&')
2244 {
2245 /* outer lexical or anon code */
748a9306 2246 av_store(newpad, ix,
4aa0a1f7 2247 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 2248 }
2249 else { /* our own lexical */
2250 if (*name == '@')
2251 av_store(newpad, ix, sv = (SV*)newAV());
2252 else if (*name == '%')
2253 av_store(newpad, ix, sv = (SV*)newHV());
2254 else
2255 av_store(newpad, ix, sv = NEWSV(0,0));
2256 SvPADMY_on(sv);
2257 }
a0d0e21e 2258 }
7766f137 2259 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
743e66e6
GS		 2260 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2261 }
a0d0e21e 2262 else {
748a9306 2263 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 2264 SvPADTMP_on(sv);
2265 }
2266 }
2267 if (cx->blk_sub.hasargs) {
2268 AV* av = newAV();
2269 av_extend(av, 0);
2270 av_store(newpad, 0, (SV*)av);
2271 AvFLAGS(av) = AVf_REIFY;
2272 }
2273 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2274 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2275 svp = AvARRAY(padlist);
2276 }
2277 }
6d4ff0d2
MB		 2278#ifdef USE_THREADS
2279 if (!cx->blk_sub.hasargs) {
533c011a 2280 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2281
93965878 2282 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2283 if (items) {
2284 /* Mark is at the end of the stack. */
924508f0
GS		 2285 EXTEND(SP, items);
2286 Copy(AvARRAY(av), SP + 1, items, SV*);
2287 SP += items;
6d4ff0d2
MB		 2288 PUTBACK ;
2289 }
2290 }
2291#endif /* USE_THREADS */
7766f137 2292 SAVEVPTR(PL_curpad);
3280af22 2293 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2294#ifndef USE_THREADS
2295 if (cx->blk_sub.hasargs)
2296#endif /* USE_THREADS */
2297 {
3280af22 2298 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2299 SV** ary;
2300
6d4ff0d2 2301#ifndef USE_THREADS
3280af22
NIS		 2302 cx->blk_sub.savearray = GvAV(PL_defgv);
2303 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2304#endif /* USE_THREADS */
2305 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2306 ++mark;
2307
2308 if (items >= AvMAX(av) + 1) {
2309 ary = AvALLOC(av);
2310 if (AvARRAY(av) != ary) {
2311 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2312 SvPVX(av) = (char*)ary;
2313 }
2314 if (items >= AvMAX(av) + 1) {
2315 AvMAX(av) = items - 1;
2316 Renew(ary,items+1,SV*);
2317 AvALLOC(av) = ary;
2318 SvPVX(av) = (char*)ary;
2319 }
2320 }
2321 Copy(mark,AvARRAY(av),items,SV*);
93965878 2322 AvFILLp(av) = items - 1;
d8b46c1b 2323 assert(!AvREAL(av));
a0d0e21e
LW		 2324 while (items--) {
2325 if (*mark)
2326 SvTEMP_off(*mark);
2327 mark++;
2328 }
2329 }
491527d0 2330 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2331 /*
2332 * We do not care about using sv to call CV;
2333 * it's for informational purposes only.
2334 */
3280af22 2335 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2336 CV *gotocv;
2337
2338 if (PERLDB_SUB_NN) {
56431972 2339 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS		 2340 } else {
2341 save_item(sv);
2342 gv_efullname3(sv, CvGV(cv), Nullch);
2343 }
2344 if ( PERLDB_GOTO
864dbfa3 2345 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2346 PUSHMARK( PL_stack_sp );
864dbfa3 2347 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2348 PL_stack_sp--;
491527d0 2349 }
1ce6579f 2350 }
a0d0e21e
LW		 2351 RETURNOP(CvSTART(cv));
2352 }
2353 }
1614b0e3 2354 else {
2d8e6c8d 2355 label = SvPV(sv,n_a);
1614b0e3 2356 if (!(do_dump || *label))
cea2e8a9 2357 DIE(aTHX_ must_have_label);
1614b0e3 2358 }
a0d0e21e 2359 }
533c011a 2360 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2361 if (! do_dump)
cea2e8a9 2362 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2363 }
2364 else
2365 label = cPVOP->op_pv;
2366
2367 if (label && *label) {
2368 OP *gotoprobe = 0;
2369
2370 /* find label */
2371
3280af22 2372 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2373 *enterops = 0;
2374 for (ix = cxstack_ix; ix >= 0; ix--) {
2375 cx = &cxstack[ix];
6b35e009 2376 switch (CxTYPE(cx)) {
a0d0e21e 2377 case CXt_EVAL:
3280af22 2378 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2379 break;
2380 case CXt_LOOP:
2381 gotoprobe = cx->blk_oldcop->op_sibling;
2382 break;
2383 case CXt_SUBST:
2384 continue;
2385 case CXt_BLOCK:
2386 if (ix)
2387 gotoprobe = cx->blk_oldcop->op_sibling;
2388 else
3280af22 2389 gotoprobe = PL_main_root;
a0d0e21e 2390 break;
b3933176
CS		 2391 case CXt_SUB:
2392 if (CvDEPTH(cx->blk_sub.cv)) {
2393 gotoprobe = CvROOT(cx->blk_sub.cv);
2394 break;
2395 }
2396 /* FALL THROUGH */
7766f137 2397 case CXt_FORMAT:
0a753a76 2398 case CXt_NULL:
a651a37d 2399 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2400 default:
2401 if (ix)
cea2e8a9 2402 DIE(aTHX_ "panic: goto");
3280af22 2403 gotoprobe = PL_main_root;
a0d0e21e
LW		 2404 break;
2405 }
2b597662
GS		 2406 if (gotoprobe) {
2407 retop = dofindlabel(gotoprobe, label,
2408 enterops, enterops + GOTO_DEPTH);
2409 if (retop)
2410 break;
2411 }
3280af22 2412 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2413 }
2414 if (!retop)
cea2e8a9 2415 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW		 2416
2417 /* pop unwanted frames */
2418
2419 if (ix < cxstack_ix) {
2420 I32 oldsave;
2421
2422 if (ix < 0)
2423 ix = 0;
2424 dounwind(ix);
2425 TOPBLOCK(cx);
3280af22 2426 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2427 LEAVE_SCOPE(oldsave);
2428 }
2429
2430 /* push wanted frames */
2431
748a9306 2432 if (*enterops && enterops[1]) {
533c011a 2433 OP *oldop = PL_op;
748a9306 2434 for (ix = 1; enterops[ix]; ix++) {
533c011a 2435 PL_op = enterops[ix];
84902520
TB		 2436 /* Eventually we may want to stack the needed arguments
2437 * for each op. For now, we punt on the hard ones. */
533c011a 2438 if (PL_op->op_type == OP_ENTERITER)
894356b3 2439 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2440 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2441 }
533c011a 2442 PL_op = oldop;
a0d0e21e
LW		 2443 }
2444 }
2445
2446 if (do_dump) {
a5f75d66 2447#ifdef VMS
6b88bc9c 2448 if (!retop) retop = PL_main_start;
a5f75d66 2449#endif
3280af22
NIS		 2450 PL_restartop = retop;
2451 PL_do_undump = TRUE;
a0d0e21e
LW		 2452
2453 my_unexec();
2454
3280af22
NIS		 2455 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2456 PL_do_undump = FALSE;
a0d0e21e
LW		 2457 }
2458
2459 RETURNOP(retop);
2460}
2461
2462PP(pp_exit)
2463{
4e35701f 2464 djSP;
a0d0e21e
LW		 2465 I32 anum;
2466
2467 if (MAXARG < 1)
2468 anum = 0;
ff0cee69 2469 else {
a0d0e21e 2470 anum = SvIVx(POPs);
d98f61e7
GS		 2471#ifdef VMS
2472 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
ff0cee69 2473 anum = 0;
2474#endif
2475 }
cc3604b1 2476 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2477 my_exit(anum);
3280af22 2478 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2479 RETURN;
2480}
2481
2482#ifdef NOTYET
2483PP(pp_nswitch)
2484{
4e35701f 2485 djSP;
65202027 2486 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2487 register I32 match = I_32(value);
2488
2489 if (value < 0.0) {
65202027 2490 if (((NV)match) > value)
a0d0e21e
LW		 2491 --match; /* was fractional--truncate other way */
2492 }
2493 match -= cCOP->uop.scop.scop_offset;
2494 if (match < 0)
2495 match = 0;
2496 else if (match > cCOP->uop.scop.scop_max)
2497 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2498 PL_op = cCOP->uop.scop.scop_next[match];
2499 RETURNOP(PL_op);
a0d0e21e
LW		 2500}
2501
2502PP(pp_cswitch)
2503{
4e35701f 2504 djSP;
a0d0e21e
LW		 2505 register I32 match;
2506
6b88bc9c
GS		 2507 if (PL_multiline)
2508 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2509 else {
2d8e6c8d
GS		 2510 STRLEN n_a;
2511 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2512 match -= cCOP->uop.scop.scop_offset;
2513 if (match < 0)
2514 match = 0;
2515 else if (match > cCOP->uop.scop.scop_max)
2516 match = cCOP->uop.scop.scop_max;
6b88bc9c 2517 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2518 }
6b88bc9c 2519 RETURNOP(PL_op);
a0d0e21e
LW		 2520}
2521#endif
2522
2523/* Eval. */
2524
0824fdcb 2525STATIC void
cea2e8a9 2526S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2527{
2528 register char *s = SvPVX(sv);
2529 register char *send = SvPVX(sv) + SvCUR(sv);
2530 register char *t;
2531 register I32 line = 1;
2532
2533 while (s && s < send) {
2534 SV *tmpstr = NEWSV(85,0);
2535
2536 sv_upgrade(tmpstr, SVt_PVMG);
2537 t = strchr(s, '\n');
2538 if (t)
2539 t++;
2540 else
2541 t = send;
2542
2543 sv_setpvn(tmpstr, s, t - s);
2544 av_store(array, line++, tmpstr);
2545 s = t;
2546 }
2547}
2548
14dd3ad8 2549#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2550STATIC void *
cea2e8a9 2551S_docatch_body(pTHX_ va_list args)
312caa8e 2552{
14dd3ad8
GS		 2553 return docatch_body();
2554}
2555#endif
2556
2557STATIC void *
2558S_docatch_body(pTHX)
2559{
cea2e8a9 2560 CALLRUNOPS(aTHX);
312caa8e
CS		 2561 return NULL;
2562}
2563
0824fdcb 2564STATIC OP *
cea2e8a9 2565S_docatch(pTHX_ OP *o)
1e422769 2566{
e858de61 2567 dTHR;
6224f72b 2568 int ret;
533c011a 2569 OP *oldop = PL_op;
0cdb2077 2570 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2571 dJMPENV;
1e422769 2572
1e422769 2573#ifdef DEBUGGING
54310121 2574 assert(CATCH_GET == TRUE);
1e422769 2575#endif
312caa8e 2576 PL_op = o;
14dd3ad8 2577#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2578 redo_body:
db36c5a1 2579 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
14dd3ad8
GS		 2580#else
2581 JMPENV_PUSH(ret);
2582#endif
6224f72b 2583 switch (ret) {
312caa8e 2584 case 0:
14dd3ad8
GS		 2585#ifndef PERL_FLEXIBLE_EXCEPTIONS
2586 redo_body:
2587 docatch_body();
2588#endif
312caa8e
CS		 2589 break;
2590 case 3:
0cdb2077 2591 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2592 PL_op = PL_restartop;
2593 PL_restartop = 0;
2594 goto redo_body;
2595 }
2596 /* FALL THROUGH */
2597 default:
14dd3ad8 2598 JMPENV_POP;
533c011a 2599 PL_op = oldop;
6224f72b 2600 JMPENV_JUMP(ret);
1e422769 2601 /* NOTREACHED */
1e422769 2602 }
14dd3ad8 2603 JMPENV_POP;
533c011a 2604 PL_op = oldop;
1e422769 2605 return Nullop;
2606}
2607
c277df42 2608OP *
864dbfa3 2609Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ		 2610/* sv Text to convert to OP tree. */
2611/* startop op_free() this to undo. */
2612/* code Short string id of the caller. */
2613{
2614 dSP; /* Make POPBLOCK work. */
2615 PERL_CONTEXT *cx;
2616 SV **newsp;
f987c7de 2617 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2618 I32 optype;
2619 OP dummy;
155aba94 2620 OP *rop;
83ee9e09
GS		 2621 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2622 char *tmpbuf = tbuf;
c277df42
IZ		 2623 char *safestr;
2624
2625 ENTER;
2626 lex_start(sv);
2627 SAVETMPS;
2628 /* switch to eval mode */
2629
cbce877f 2630 if (PL_curcop == &PL_compiling) {
11faa288
GS		 2631 SAVECOPSTASH(&PL_compiling);
2632 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2633 }
57843af0
GS		 2634 SAVECOPFILE(&PL_compiling);
2635 SAVECOPLINE(&PL_compiling);
83ee9e09
GS		 2636 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2637 SV *sv = sv_newmortal();
2638 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2639 code, (unsigned long)++PL_evalseq,
2640 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2641 tmpbuf = SvPVX(sv);
2642 }
2643 else
2644 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
57843af0
GS		 2645 CopFILE_set(&PL_compiling, tmpbuf+2);
2646 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2647 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2648 deleting the eval's FILEGV from the stash before gv_check() runs
2649 (i.e. before run-time proper). To work around the coredump that
2650 ensues, we always turn GvMULTI_on for any globals that were
2651 introduced within evals. See force_ident(). GSAR 96-10-12 */
2652 safestr = savepv(tmpbuf);
3280af22 2653 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2654 SAVEHINTS();
d1ca3daa 2655#ifdef OP_IN_REGISTER
6b88bc9c 2656 PL_opsave = op;
d1ca3daa 2657#else
7766f137 2658 SAVEVPTR(PL_op);
d1ca3daa 2659#endif
3280af22 2660 PL_hints = 0;
c277df42 2661
533c011a 2662 PL_op = &dummy;
13b51b79 2663 PL_op->op_type = OP_ENTEREVAL;
533c011a 2664 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2665 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2666 PUSHEVAL(cx, 0, Nullgv);
c277df42 2667 rop = doeval(G_SCALAR, startop);
13b51b79 2668 POPBLOCK(cx,PL_curpm);
e84b9f1f 2669 POPEVAL(cx);
c277df42
IZ		 2670
2671 (*startop)->op_type = OP_NULL;
22c35a8c 2672 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2673 lex_end();
3280af22 2674 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2675 LEAVE;
13b51b79 2676 if (PL_curcop == &PL_compiling)
a0ed51b3 2677 PL_compiling.op_private = PL_hints;
d1ca3daa 2678#ifdef OP_IN_REGISTER
6b88bc9c 2679 op = PL_opsave;
d1ca3daa 2680#endif
c277df42
IZ		 2681 return rop;
2682}
2683
0f15f207 2684/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2685STATIC OP *
cea2e8a9 2686S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW		 2687{
2688 dSP;
533c011a 2689 OP *saveop = PL_op;
ff3ff8d1 2690 CV *caller;
748a9306 2691 AV* comppadlist;
67a38de0 2692 I32 i;
a0d0e21e 2693
faef0170 2694 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2695
1ce6579f 2696 PUSHMARK(SP);
2697
a0d0e21e
LW		 2698 /* set up a scratch pad */
2699
3280af22 2700 SAVEI32(PL_padix);
7766f137 2701 SAVEVPTR(PL_curpad);
3280af22
NIS		 2702 SAVESPTR(PL_comppad);
2703 SAVESPTR(PL_comppad_name);
2704 SAVEI32(PL_comppad_name_fill);
2705 SAVEI32(PL_min_intro_pending);
2706 SAVEI32(PL_max_intro_pending);
748a9306 2707
3280af22 2708 caller = PL_compcv;
6b35e009 2709 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2710 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2711 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2712 break;
7766f137 2713 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
67a38de0
NIS		 2714 caller = cx->blk_sub.cv;
2715 break;
2716 }
2717 }
2718
3280af22
NIS		 2719 SAVESPTR(PL_compcv);
2720 PL_compcv = (CV*)NEWSV(1104,0);
2721 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2722 CvEVAL_on(PL_compcv);
11343788 2723#ifdef USE_THREADS
533c011a
NIS		 2724 CvOWNER(PL_compcv) = 0;
2725 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2726 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2727#endif /* USE_THREADS */
748a9306 2728
3280af22
NIS		 2729 PL_comppad = newAV();
2730 av_push(PL_comppad, Nullsv);
2731 PL_curpad = AvARRAY(PL_comppad);
2732 PL_comppad_name = newAV();
2733 PL_comppad_name_fill = 0;
2734 PL_min_intro_pending = 0;
2735 PL_padix = 0;
11343788 2736#ifdef USE_THREADS
79cb57f6 2737 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 2738 PL_curpad[0] = (SV*)newAV();
2739 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2740#endif /* USE_THREADS */
a0d0e21e 2741
748a9306
LW		 2742 comppadlist = newAV();
2743 AvREAL_off(comppadlist);
3280af22
NIS		 2744 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2745 av_store(comppadlist, 1, (SV*)PL_comppad);
2746 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2747
faa7e5bb
GS		 2748 if (!saveop ||
2749 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2750 {
3280af22 2751 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
faa7e5bb 2752 }
07055b4c 2753
3280af22 2754 SAVEFREESV(PL_compcv);
748a9306 2755
a0d0e21e
LW		 2756 /* make sure we compile in the right package */
2757
ed094faf 2758 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2759 SAVESPTR(PL_curstash);
ed094faf 2760 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2761 }
3280af22
NIS		 2762 SAVESPTR(PL_beginav);
2763 PL_beginav = newAV();
2764 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2765
2766 /* try to compile it */
2767
3280af22
NIS		 2768 PL_eval_root = Nullop;
2769 PL_error_count = 0;
2770 PL_curcop = &PL_compiling;
2771 PL_curcop->cop_arybase = 0;
2772 SvREFCNT_dec(PL_rs);
79cb57f6 2773 PL_rs = newSVpvn("\n", 1);
c277df42 2774 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2775 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2776 else
38a03e6e 2777 sv_setpv(ERRSV,"");
3280af22 2778 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2779 SV **newsp;
2780 I32 gimme;
c09156bb 2781 PERL_CONTEXT *cx;
c277df42 2782 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2783 STRLEN n_a;
097ee67d 2784
533c011a 2785 PL_op = saveop;
3280af22
NIS		 2786 if (PL_eval_root) {
2787 op_free(PL_eval_root);
2788 PL_eval_root = Nullop;
a0d0e21e 2789 }
3280af22 2790 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2791 if (!startop) {
3280af22 2792 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2793 POPEVAL(cx);
2794 pop_return();
2795 }
a0d0e21e
LW		 2796 lex_end();
2797 LEAVE;
7a2e2cd6 2798 if (optype == OP_REQUIRE) {
2d8e6c8d 2799 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 2800 DIE(aTHX_ "%sCompilation failed in require",
2801 *msg ? msg : "Unknown error\n");
2802 }
2803 else if (startop) {
2d8e6c8d 2804 char* msg = SvPVx(ERRSV, n_a);
c277df42 2805
3280af22 2806 POPBLOCK(cx,PL_curpm);
c277df42 2807 POPEVAL(cx);
5a844595
GS		 2808 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2809 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2810 }
3280af22
NIS		 2811 SvREFCNT_dec(PL_rs);
2812 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2813#ifdef USE_THREADS
533c011a
NIS		 2814 MUTEX_LOCK(&PL_eval_mutex);
2815 PL_eval_owner = 0;
2816 COND_SIGNAL(&PL_eval_cond);
2817 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2818#endif /* USE_THREADS */
a0d0e21e
LW		 2819 RETPUSHUNDEF;
2820 }
3280af22
NIS		 2821 SvREFCNT_dec(PL_rs);
2822 PL_rs = SvREFCNT_inc(PL_nrs);
57843af0 2823 CopLINE_set(&PL_compiling, 0);
c277df42 2824 if (startop) {
3280af22
NIS		 2825 *startop = PL_eval_root;
2826 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2827 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2828 } else
3280af22 2829 SAVEFREEOP(PL_eval_root);
54310121 2830 if (gimme & G_VOID)
3280af22 2831 scalarvoid(PL_eval_root);
54310121 2832 else if (gimme & G_ARRAY)
3280af22 2833 list(PL_eval_root);
a0d0e21e 2834 else
3280af22 2835 scalar(PL_eval_root);
a0d0e21e
LW		 2836
2837 DEBUG_x(dump_eval());
2838
55497cff 2839 /* Register with debugger: */
84902520 2840 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2841 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2842 if (cv) {
2843 dSP;
924508f0 2844 PUSHMARK(SP);
cc49e20b 2845 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2846 PUTBACK;
864dbfa3 2847 call_sv((SV*)cv, G_DISCARD);
55497cff 2848 }
2849 }
2850
a0d0e21e
LW		 2851 /* compiled okay, so do it */
2852
3280af22
NIS		 2853 CvDEPTH(PL_compcv) = 1;
2854 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2855 PL_op = saveop; /* The caller may need it. */
b35b2403 2856#ifdef USE_THREADS
533c011a
NIS		 2857 MUTEX_LOCK(&PL_eval_mutex);
2858 PL_eval_owner = 0;
2859 COND_SIGNAL(&PL_eval_cond);
2860 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2861#endif /* USE_THREADS */
5dc0d613 2862
3280af22 2863 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2864}
2865
a6c40364 2866STATIC PerlIO *
cea2e8a9 2867S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2868{
2869 STRLEN namelen = strlen(name);
2870 PerlIO *fp;
2871
7894fbab 2872 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2873 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2874 char *pmc = SvPV_nolen(pmcsv);
2875 Stat_t pmstat;
a6c40364
GS		 2876 Stat_t pmcstat;
2877 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2878 fp = PerlIO_open(name, mode);
a6c40364
GS		 2879 }
2880 else {
b295d113 2881 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2882 pmstat.st_mtime < pmcstat.st_mtime)
2883 {
2884 fp = PerlIO_open(pmc, mode);
2885 }
2886 else {
2887 fp = PerlIO_open(name, mode);
2888 }
b295d113 2889 }
a6c40364
GS		 2890 SvREFCNT_dec(pmcsv);
2891 }
2892 else {
2893 fp = PerlIO_open(name, mode);
b295d113 2894 }
b295d113
TH		 2895 return fp;
2896}
2897
a0d0e21e
LW		 2898PP(pp_require)
2899{
4e35701f 2900 djSP;
c09156bb 2901 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2902 SV *sv;
2903 char *name;
6132ea6c 2904 STRLEN len;
46fc3d4c 2905 char *tryname;
2906 SV *namesv = Nullsv;
a0d0e21e
LW		 2907 SV** svp;
2908 I32 gimme = G_SCALAR;
760ac839 2909 PerlIO *tryrsfp = 0;
2d8e6c8d 2910 STRLEN n_a;
bbed91b5
KF		 2911 int filter_has_file = 0;
2912 GV *filter_child_proc = 0;
2913 SV *filter_state = 0;
2914 SV *filter_sub = 0;
a0d0e21e
LW		 2915
2916 sv = POPs;
a7cb1f99 2917 if (SvNIOKp(sv)) {
4305d8ab
GS		 2918 if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
2919 UV rev = 0, ver = 0, sver = 0;
a7cb1f99
GS		 2920 I32 len;
2921 U8 *s = (U8*)SvPVX(sv);
2922 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2923 if (s < end) {
2924 rev = utf8_to_uv(s, &len);
2925 s += len;
2926 if (s < end) {
2927 ver = utf8_to_uv(s, &len);
2928 s += len;
2929 if (s < end)
2930 sver = utf8_to_uv(s, &len);
a7cb1f99 2931 }
a7cb1f99 2932 }
a7cb1f99
GS		 2933 if (PERL_REVISION < rev
2934 || (PERL_REVISION == rev
2935 && (PERL_VERSION < ver
2936 || (PERL_VERSION == ver
2937 && PERL_SUBVERSION < sver))))
2938 {
cc507455 2939 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
894356b3 2940 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS		 2941 PERL_VERSION, PERL_SUBVERSION);
2942 }
4305d8ab 2943 RETPUSHYES;
a7cb1f99
GS		 2944 }
2945 else if (!SvPOKp(sv)) { /* require 5.005_03 */
a7cb1f99
GS		 2946 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2947 + ((NV)PERL_SUBVERSION/(NV)1000000)
2948 + 0.00000099 < SvNV(sv))
2949 {
dbe7b177
GS		 2950 NV nrev = SvNV(sv);
2951 UV rev = (UV)nrev;
2952 NV nver = (nrev - rev) * 1000;
2953 UV ver = (UV)(nver + 0.0009);
2954 NV nsver = (nver - ver) * 1000;
2955 UV sver = (UV)(nsver + 0.0009);
2956
cc507455
GS		 2957 /* help out with the "use 5.6" confusion */
2958 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2959 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2960 "this is only v%d.%d.%d, stopped"
2961 " (did you mean v%"UVuf".%"UVuf".0?)",
2962 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2963 PERL_SUBVERSION, rev, ver/100);
2964 }
2965 else {
2966 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2967 "this is only v%d.%d.%d, stopped",
2968 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2969 PERL_SUBVERSION);
2970 }
a7cb1f99 2971 }
4305d8ab 2972 RETPUSHYES;
a7cb1f99 2973 }
a0d0e21e 2974 }
6132ea6c
GS		 2975 name = SvPV(sv, len);
2976 if (!(name && len > 0 && *name))
cea2e8a9 2977 DIE(aTHX_ "Null filename used");
4633a7c4 2978 TAINT_PROPER("require");
533c011a 2979 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2980 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2981 *svp != &PL_sv_undef)
a0d0e21e
LW		 2982 RETPUSHYES;
2983
2984 /* prepare to compile file */
2985
57843af0
GS		 2986 if (PERL_FILE_IS_ABSOLUTE(name)
2987 || (*name == '.' && (name[1] == '/' ||
2988 (name[1] == '.' && name[2] == '/'))))
a0d0e21e 2989 {
46fc3d4c 2990 tryname = name;
a6c40364 2991 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2992 }
2993 else {
3280af22 2994 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2995 I32 i;
748a9306 2996#ifdef VMS
46fc3d4c 2997 char *unixname;
2998 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2999#endif
3000 {
3001 namesv = NEWSV(806, 0);
3002 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 3003 SV *dirsv = *av_fetch(ar, i, TRUE);
3004
3005 if (SvROK(dirsv)) {
3006 int count;
3007 SV *loader = dirsv;
3008
3009 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3010 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3011 }
3012
b900a521
JH		 3013 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3014 PTR2UV(SvANY(loader)), name);
bbed91b5
KF		 3015 tryname = SvPVX(namesv);
3016 tryrsfp = 0;
3017
3018 ENTER;
3019 SAVETMPS;
3020 EXTEND(SP, 2);
3021
3022 PUSHMARK(SP);
3023 PUSHs(dirsv);
3024 PUSHs(sv);
3025 PUTBACK;
3026 count = call_sv(loader, G_ARRAY);
3027 SPAGAIN;
3028
3029 if (count > 0) {
3030 int i = 0;
3031 SV *arg;
3032
3033 SP -= count - 1;
3034 arg = SP[i++];
3035
3036 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3037 arg = SvRV(arg);
3038 }
3039
3040 if (SvTYPE(arg) == SVt_PVGV) {
3041 IO *io = GvIO((GV *)arg);
3042
3043 ++filter_has_file;
3044
3045 if (io) {
3046 tryrsfp = IoIFP(io);
3047 if (IoTYPE(io) == '|') {
3048 /* reading from a child process doesn't
3049 nest -- when returning from reading
3050 the inner module, the outer one is
3051 unreadable (closed?) I've tried to
3052 save the gv to manage the lifespan of
3053 the pipe, but this didn't help. XXX */
3054 filter_child_proc = (GV *)arg;
520c758a 3055 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3056 }
3057 else {
3058 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3059 PerlIO_close(IoOFP(io));
3060 }
3061 IoIFP(io) = Nullfp;
3062 IoOFP(io) = Nullfp;
3063 }
3064 }
3065
3066 if (i < count) {
3067 arg = SP[i++];
3068 }
3069 }
3070
3071 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3072 filter_sub = arg;
520c758a 3073 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3074
3075 if (i < count) {
3076 filter_state = SP[i];
520c758a 3077 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3078 }
3079
3080 if (tryrsfp == 0) {
3081 tryrsfp = PerlIO_open("/dev/null",
3082 PERL_SCRIPT_MODE);
3083 }
3084 }
3085 }
3086
3087 PUTBACK;
3088 FREETMPS;
3089 LEAVE;
3090
3091 if (tryrsfp) {
3092 break;
3093 }
3094
3095 filter_has_file = 0;
3096 if (filter_child_proc) {
3097 SvREFCNT_dec(filter_child_proc);
3098 filter_child_proc = 0;
3099 }
3100 if (filter_state) {
3101 SvREFCNT_dec(filter_state);
3102 filter_state = 0;
3103 }
3104 if (filter_sub) {
3105 SvREFCNT_dec(filter_sub);
3106 filter_sub = 0;
3107 }
3108 }
3109 else {
3110 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 3111#ifdef VMS
bbed91b5
KF		 3112 char *unixdir;
3113 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3114 continue;
3115 sv_setpv(namesv, unixdir);
3116 sv_catpv(namesv, unixname);
748a9306 3117#else
bbed91b5 3118 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3119#endif
bbed91b5
KF		 3120 TAINT_PROPER("require");
3121 tryname = SvPVX(namesv);
3122 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3123 if (tryrsfp) {
3124 if (tryname[0] == '.' && tryname[1] == '/')
3125 tryname += 2;
3126 break;
3127 }
46fc3d4c 3128 }
a0d0e21e
LW		 3129 }
3130 }
3131 }
57843af0
GS		 3132 SAVECOPFILE(&PL_compiling);
3133 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3134 SvREFCNT_dec(namesv);
a0d0e21e 3135 if (!tryrsfp) {
533c011a 3136 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 3137 char *msgstr = name;
3138 if (namesv) { /* did we lookup @INC? */
3139 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3140 SV *dirmsgsv = NEWSV(0, 0);
3141 AV *ar = GvAVn(PL_incgv);
3142 I32 i;
3143 sv_catpvn(msg, " in @INC", 8);
3144 if (instr(SvPVX(msg), ".h "))
3145 sv_catpv(msg, " (change .h to .ph maybe?)");
3146 if (instr(SvPVX(msg), ".ph "))
3147 sv_catpv(msg, " (did you run h2ph?)");
3148 sv_catpv(msg, " (@INC contains:");
3149 for (i = 0; i <= AvFILL(ar); i++) {
3150 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3151 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3152 sv_catsv(msg, dirmsgsv);
3153 }
3154 sv_catpvn(msg, ")", 1);
3155 SvREFCNT_dec(dirmsgsv);
3156 msgstr = SvPV_nolen(msg);
2683423c 3157 }
cea2e8a9 3158 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3159 }
3160
3161 RETPUSHUNDEF;
3162 }
d8bfb8bd 3163 else
aba27d88 3164 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 3165
3166 /* Assume success here to prevent recursive requirement. */
3280af22 3167 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
ed094faf 3168 newSVpv(CopFILE(&PL_compiling), 0), 0 );
a0d0e21e
LW		 3169
3170 ENTER;
3171 SAVETMPS;
79cb57f6 3172 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3173 SAVEGENERICSV(PL_rsfp_filters);
3174 PL_rsfp_filters = Nullav;
e50aee73 3175
3280af22 3176 PL_rsfp = tryrsfp;
b3ac6de7 3177 SAVEHINTS();
3280af22 3178 PL_hints = 0;
7766f137 3179 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3180 if (PL_dowarn & G_WARN_ALL_ON)
d3a7d8c7 3181 PL_compiling.cop_warnings = pWARN_ALL ;
0453d815 3182 else if (PL_dowarn & G_WARN_ALL_OFF)
d3a7d8c7 3183 PL_compiling.cop_warnings = pWARN_NONE ;
0453d815 3184 else
d3a7d8c7 3185 PL_compiling.cop_warnings = pWARN_STD ;
a0d0e21e 3186
bbed91b5
KF		 3187 if (filter_sub || filter_child_proc) {
3188 SV *datasv = filter_add(run_user_filter, Nullsv);
3189 IoLINES(datasv) = filter_has_file;
3190 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3191 IoTOP_GV(datasv) = (GV *)filter_state;
3192 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3193 }
3194
3195 /* switch to eval mode */
533c011a 3196 push_return(PL_op->op_next);
a0d0e21e 3197 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3198 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3199
57843af0
GS		 3200 SAVECOPLINE(&PL_compiling);
3201 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3202
3203 PUTBACK;
0f15f207 3204#ifdef USE_THREADS
533c011a
NIS		 3205 MUTEX_LOCK(&PL_eval_mutex);
3206 if (PL_eval_owner && PL_eval_owner != thr)
3207 while (PL_eval_owner)
3208 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3209 PL_eval_owner = thr;
3210 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3211#endif /* USE_THREADS */
c277df42 3212 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 3213}
3214
3215PP(pp_dofile)
3216{
cea2e8a9 3217 return pp_require();
a0d0e21e
LW		 3218}
3219
3220PP(pp_entereval)
3221{
4e35701f 3222 djSP;
c09156bb 3223 register PERL_CONTEXT *cx;
a0d0e21e 3224 dPOPss;
3280af22 3225 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3226 char tbuf[TYPE_DIGITS(long) + 12];
3227 char *tmpbuf = tbuf;
fc36a67e 3228 char *safestr;
a0d0e21e 3229 STRLEN len;
55497cff 3230 OP *ret;
a0d0e21e
LW		 3231
3232 if (!SvPV(sv,len) || !len)
3233 RETPUSHUNDEF;
748a9306 3234 TAINT_PROPER("eval");
a0d0e21e
LW		 3235
3236 ENTER;
a0d0e21e 3237 lex_start(sv);
748a9306 3238 SAVETMPS;
a0d0e21e
LW		 3239
3240 /* switch to eval mode */
3241
57843af0 3242 SAVECOPFILE(&PL_compiling);
83ee9e09
GS		 3243 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3244 SV *sv = sv_newmortal();
3245 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3246 (unsigned long)++PL_evalseq,
3247 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3248 tmpbuf = SvPVX(sv);
3249 }
3250 else
3251 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
57843af0
GS		 3252 CopFILE_set(&PL_compiling, tmpbuf+2);
3253 CopLINE_set(&PL_compiling, 1);
55497cff 3254 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3255 deleting the eval's FILEGV from the stash before gv_check() runs
3256 (i.e. before run-time proper). To work around the coredump that
3257 ensues, we always turn GvMULTI_on for any globals that were
3258 introduced within evals. See force_ident(). GSAR 96-10-12 */
3259 safestr = savepv(tmpbuf);
3280af22 3260 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3261 SAVEHINTS();
533c011a 3262 PL_hints = PL_op->op_targ;
7766f137 3263 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3264 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 3265 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3266 SAVEFREESV(PL_compiling.cop_warnings) ;
3267 }
a0d0e21e 3268
533c011a 3269 push_return(PL_op->op_next);
6b35e009 3270 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3271 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW		 3272
3273 /* prepare to compile string */
3274
3280af22 3275 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3276 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3277 PUTBACK;
0f15f207 3278#ifdef USE_THREADS
533c011a
NIS		 3279 MUTEX_LOCK(&PL_eval_mutex);
3280 if (PL_eval_owner && PL_eval_owner != thr)
3281 while (PL_eval_owner)
3282 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3283 PL_eval_owner = thr;
3284 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3285#endif /* USE_THREADS */
c277df42 3286 ret = doeval(gimme, NULL);
3280af22 3287 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3288 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3289 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3290 }
1e422769 3291 return DOCATCH(ret);
a0d0e21e
LW		 3292}
3293
3294PP(pp_leaveeval)
3295{
4e35701f 3296 djSP;
a0d0e21e
LW		 3297 register SV **mark;
3298 SV **newsp;
3299 PMOP *newpm;
3300 I32 gimme;
c09156bb 3301 register PERL_CONTEXT *cx;
a0d0e21e 3302 OP *retop;
533c011a 3303 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3304 I32 optype;
3305
3306 POPBLOCK(cx,newpm);
3307 POPEVAL(cx);
3308 retop = pop_return();
3309
a1f49e72 3310 TAINT_NOT;
54310121 3311 if (gimme == G_VOID)
3312 MARK = newsp;
3313 else if (gimme == G_SCALAR) {
3314 MARK = newsp + 1;
3315 if (MARK <= SP) {
3316 if (SvFLAGS(TOPs) & SVs_TEMP)
3317 *MARK = TOPs;
3318 else
3319 *MARK = sv_mortalcopy(TOPs);
3320 }
a0d0e21e 3321 else {
54310121 3322 MEXTEND(mark,0);
3280af22 3323 *MARK = &PL_sv_undef;
a0d0e21e 3324 }
a7ec2b44 3325 SP = MARK;
a0d0e21e
LW		 3326 }
3327 else {
a1f49e72
CS		 3328 /* in case LEAVE wipes old return values */
3329 for (mark = newsp + 1; mark <= SP; mark++) {
3330 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3331 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3332 TAINT_NOT; /* Each item is independent */
3333 }
3334 }
a0d0e21e 3335 }
3280af22 3336 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3337
067f92a0
GS		 3338 if (AvFILLp(PL_comppad_name) >= 0)
3339 free_closures();
84902520 3340
4fdae800 3341#ifdef DEBUGGING
3280af22 3342 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3343#endif
3280af22 3344 CvDEPTH(PL_compcv) = 0;
f46d017c 3345 lex_end();
4fdae800 3346
1ce6579f 3347 if (optype == OP_REQUIRE &&
924508f0 3348 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3349 {
1ce6579f 3350 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 3351 SV *nsv = cx->blk_eval.old_namesv;
3352 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3353 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
f46d017c
GS		 3354 /* die_where() did LEAVE, or we won't be here */
3355 }
3356 else {
3357 LEAVE;
3358 if (!(save_flags & OPf_SPECIAL))
3359 sv_setpv(ERRSV,"");
a0d0e21e 3360 }
a0d0e21e
LW		 3361
3362 RETURNOP(retop);
3363}
3364
a0d0e21e
LW		 3365PP(pp_entertry)
3366{
4e35701f 3367 djSP;
c09156bb 3368 register PERL_CONTEXT *cx;
54310121 3369 I32 gimme = GIMME_V;
a0d0e21e
LW		 3370
3371 ENTER;
3372 SAVETMPS;
3373
3374 push_return(cLOGOP->op_other->op_next);
1d76a5c3 3375 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
a0d0e21e 3376 PUSHEVAL(cx, 0, 0);
533c011a 3377 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3378
faef0170 3379 PL_in_eval = EVAL_INEVAL;
38a03e6e 3380 sv_setpv(ERRSV,"");
1e422769 3381 PUTBACK;
533c011a 3382 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3383}
3384
3385PP(pp_leavetry)
3386{
4e35701f 3387 djSP;
a0d0e21e
LW		 3388 register SV **mark;
3389 SV **newsp;
3390 PMOP *newpm;
3391 I32 gimme;
c09156bb 3392 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3393 I32 optype;
3394
3395 POPBLOCK(cx,newpm);
3396 POPEVAL(cx);
3397 pop_return();
3398
a1f49e72 3399 TAINT_NOT;
54310121 3400 if (gimme == G_VOID)
3401 SP = newsp;
3402 else if (gimme == G_SCALAR) {
3403 MARK = newsp + 1;
3404 if (MARK <= SP) {
3405 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3406 *MARK = TOPs;
3407 else
3408 *MARK = sv_mortalcopy(TOPs);
3409 }
a0d0e21e 3410 else {
54310121 3411 MEXTEND(mark,0);
3280af22 3412 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3413 }
3414 SP = MARK;
3415 }
3416 else {
a1f49e72
CS		 3417 /* in case LEAVE wipes old return values */
3418 for (mark = newsp + 1; mark <= SP; mark++) {
3419 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3420 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3421 TAINT_NOT; /* Each item is independent */
3422 }
3423 }
a0d0e21e 3424 }
3280af22 3425 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3426
3427 LEAVE;
38a03e6e 3428 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3429 RETURN;
3430}
3431
0824fdcb 3432STATIC void
cea2e8a9 3433S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3434{
3435 STRLEN len;
3436 register char *s = SvPV_force(sv, len);
3437 register char *send = s + len;
3438 register char *base;
3439 register I32 skipspaces = 0;
3440 bool noblank;
3441 bool repeat;
3442 bool postspace = FALSE;
3443 U16 *fops;
3444 register U16 *fpc;
3445 U16 *linepc;
3446 register I32 arg;
3447 bool ischop;
3448
55497cff 3449 if (len == 0)
cea2e8a9 3450 Perl_croak(aTHX_ "Null picture in formline");
55497cff 3451
3452 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3453 fpc = fops;
3454
3455 if (s < send) {
3456 linepc = fpc;
3457 *fpc++ = FF_LINEMARK;
3458 noblank = repeat = FALSE;
3459 base = s;
3460 }
3461
3462 while (s <= send) {
3463 switch (*s++) {
3464 default:
3465 skipspaces = 0;
3466 continue;
3467
3468 case '~':
3469 if (*s == '~') {
3470 repeat = TRUE;
3471 *s = ' ';
3472 }
3473 noblank = TRUE;
3474 s[-1] = ' ';
3475 /* FALL THROUGH */
3476 case ' ': case '\t':
3477 skipspaces++;
3478 continue;
3479
3480 case '\n': case 0:
3481 arg = s - base;
3482 skipspaces++;
3483 arg -= skipspaces;
3484 if (arg) {
5f05dabc 3485 if (postspace)
a0d0e21e 3486 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3487 *fpc++ = FF_LITERAL;
3488 *fpc++ = arg;
3489 }
5f05dabc 3490 postspace = FALSE;
a0d0e21e
LW		 3491 if (s <= send)
3492 skipspaces--;
3493 if (skipspaces) {
3494 *fpc++ = FF_SKIP;
3495 *fpc++ = skipspaces;
3496 }
3497 skipspaces = 0;
3498 if (s <= send)
3499 *fpc++ = FF_NEWLINE;
3500 if (noblank) {
3501 *fpc++ = FF_BLANK;
3502 if (repeat)
3503 arg = fpc - linepc + 1;
3504 else
3505 arg = 0;
3506 *fpc++ = arg;
3507 }
3508 if (s < send) {
3509 linepc = fpc;
3510 *fpc++ = FF_LINEMARK;
3511 noblank = repeat = FALSE;
3512 base = s;
3513 }
3514 else
3515 s++;
3516 continue;
3517
3518 case '@':
3519 case '^':
3520 ischop = s[-1] == '^';
3521
3522 if (postspace) {
3523 *fpc++ = FF_SPACE;
3524 postspace = FALSE;
3525 }
3526 arg = (s - base) - 1;
3527 if (arg) {
3528 *fpc++ = FF_LITERAL;
3529 *fpc++ = arg;
3530 }
3531
3532 base = s - 1;
3533 *fpc++ = FF_FETCH;
3534 if (*s == '*') {
3535 s++;
3536 *fpc++ = 0;
3537 *fpc++ = FF_LINEGLOB;
3538 }
3539 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3540 arg = ischop ? 512 : 0;
3541 base = s - 1;
3542 while (*s == '#')
3543 s++;
3544 if (*s == '.') {
3545 char *f;
3546 s++;
3547 f = s;
3548 while (*s == '#')
3549 s++;
3550 arg |= 256 + (s - f);
3551 }
3552 *fpc++ = s - base; /* fieldsize for FETCH */
3553 *fpc++ = FF_DECIMAL;
3554 *fpc++ = arg;
3555 }
3556 else {
3557 I32 prespace = 0;
3558 bool ismore = FALSE;
3559
3560 if (*s == '>') {
3561 while (*++s == '>') ;
3562 prespace = FF_SPACE;
3563 }
3564 else if (*s == '|') {
3565 while (*++s == '|') ;
3566 prespace = FF_HALFSPACE;
3567 postspace = TRUE;
3568 }
3569 else {
3570 if (*s == '<')
3571 while (*++s == '<') ;
3572 postspace = TRUE;
3573 }
3574 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3575 s += 3;
3576 ismore = TRUE;
3577 }
3578 *fpc++ = s - base; /* fieldsize for FETCH */
3579
3580 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3581
3582 if (prespace)
3583 *fpc++ = prespace;
3584 *fpc++ = FF_ITEM;
3585 if (ismore)
3586 *fpc++ = FF_MORE;
3587 if (ischop)
3588 *fpc++ = FF_CHOP;
3589 }
3590 base = s;
3591 skipspaces = 0;
3592 continue;
3593 }
3594 }
3595 *fpc++ = FF_END;