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