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