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
installperl should write normal messages to STDOUT, not STDERR
[perl5.git] / pp_ctl.c
CommitLineData
a0d0e21e
LW		 1/* pp_ctl.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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
76e3520e 29#ifdef PERL_OBJECT
4c2891ed 30#define CALLOP this->*PL_op
76e3520e 31#else
533c011a 32#define CALLOP *PL_op
76e3520e 33#endif
a0d0e21e 34
a0d0e21e
LW		 35PP(pp_wantarray)
36{
4e35701f 37 djSP;
a0d0e21e
LW		 38 I32 cxix;
39 EXTEND(SP, 1);
40
41 cxix = dopoptosub(cxstack_ix);
42 if (cxix < 0)
43 RETPUSHUNDEF;
44
54310121 45 switch (cxstack[cxix].blk_gimme) {
46 case G_ARRAY:
a0d0e21e 47 RETPUSHYES;
54310121 48 case G_SCALAR:
a0d0e21e 49 RETPUSHNO;
54310121 50 default:
51 RETPUSHUNDEF;
52 }
a0d0e21e
LW		 53}
54
55PP(pp_regcmaybe)
56{
57 return NORMAL;
58}
59
2cd61cdb
IZ		 60PP(pp_regcreset)
61{
62 /* XXXX Should store the old value to allow for tie/overload - and
63 restore in regcomp, where marked with XXXX. */
3280af22 64 PL_reginterp_cnt = 0;
2cd61cdb
IZ		 65 return NORMAL;
66}
67
b3eb6a9b
GS		 68PP(pp_regcomp)
69{
4e35701f 70 djSP;
a0d0e21e
LW		 71 register PMOP *pm = (PMOP*)cLOGOP->op_other;
72 register char *t;
73 SV *tmpstr;
74 STRLEN len;
c277df42 75 MAGIC *mg = Null(MAGIC*);
a0d0e21e
LW		 76
77 tmpstr = POPs;
b3eb6a9b 78 if (SvROK(tmpstr)) {
227a8b4b 79 SV *sv = SvRV(tmpstr);
c277df42
IZ		 80 if(SvMAGICAL(sv))
81 mg = mg_find(sv, 'r');
82 }
b3eb6a9b 83 if (mg) {
c277df42
IZ		 84 regexp *re = (regexp *)mg->mg_obj;
85 ReREFCNT_dec(pm->op_pmregexp);
86 pm->op_pmregexp = ReREFCNT_inc(re);
87 }
88 else {
89 t = SvPV(tmpstr, len);
90
20408e3c 91 /* Check against the last compiled regexp. */
85aff577 92 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
20408e3c
GS		 93 pm->op_pmregexp->prelen != len ||
94 memNE(pm->op_pmregexp->precomp, t, len))
85aff577 95 {
c277df42
IZ		 96 if (pm->op_pmregexp) {
97 ReREFCNT_dec(pm->op_pmregexp);
98 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
99 }
533c011a 100 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 101 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 102
c277df42 103 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
cea2e8a9 104 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
3280af22 105 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 106 inside tie/overload accessors. */
c277df42 107 }
4633a7c4 108 }
a0d0e21e 109
72311751 110#ifndef INCOMPLETE_TAINTS
3280af22
NIS		 111 if (PL_tainting) {
112 if (PL_tainted)
72311751
GS		 113 pm->op_pmdynflags |= PMdf_TAINTED;
114 else
115 pm->op_pmdynflags &= ~PMdf_TAINTED;
116 }
117#endif
118
3280af22
NIS		 119 if (!pm->op_pmregexp->prelen && PL_curpm)
120 pm = PL_curpm;
a0d0e21e
LW		 121 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
122 pm->op_pmflags |= PMf_WHITE;
123
124 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 125 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
533c011a 126 cLOGOP->op_first->op_next = PL_op->op_next;
a0d0e21e
LW		 127 }
128 RETURN;
129}
130
131PP(pp_substcont)
132{
4e35701f 133 djSP;
a0d0e21e 134 register PMOP *pm = (PMOP*) cLOGOP->op_other;
c09156bb 135 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
a0d0e21e
LW		 136 register SV *dstr = cx->sb_dstr;
137 register char *s = cx->sb_s;
138 register char *m = cx->sb_m;
139 char *orig = cx->sb_orig;
d9f97599 140 register REGEXP *rx = cx->sb_rx;
a0d0e21e 141
d9f97599 142 rxres_restore(&cx->sb_rxres, rx);
c90c0ff4 143
a0d0e21e
LW		 144 if (cx->sb_iters++) {
145 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 146 DIE(aTHX_ "Substitution loop");
a0d0e21e 147
48c036b1
GS		 148 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
149 cx->sb_rxtainted |= 2;
a0d0e21e 150 sv_catsv(dstr, POPs);
a0d0e21e
LW		 151
152 /* Are we done */
cea2e8a9 153 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
9661b544 154 s == m, cx->sb_targ, NULL,
22e551b9 155 ((cx->sb_rflags & REXEC_COPY_STR)
cf93c79d
IZ		 156 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
157 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e
LW		 158 {
159 SV *targ = cx->sb_targ;
160 sv_catpvn(dstr, s, cx->sb_strend - s);
748a9306 161
48c036b1 162 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 163
4633a7c4 164 (void)SvOOK_off(targ);
cb0b1708 165 Safefree(SvPVX(targ));
748a9306
LW		 166 SvPVX(targ) = SvPVX(dstr);
167 SvCUR_set(targ, SvCUR(dstr));
168 SvLEN_set(targ, SvLEN(dstr));
169 SvPVX(dstr) = 0;
170 sv_free(dstr);
48c036b1
GS		 171
172 TAINT_IF(cx->sb_rxtainted & 1);
173 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
174
a0d0e21e 175 (void)SvPOK_only(targ);
48c036b1 176 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 177 SvSETMAGIC(targ);
9212bbba 178 SvTAINT(targ);
5cd24f17 179
4633a7c4 180 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW		 181 POPSUBST(cx);
182 RETURNOP(pm->op_next);
183 }
184 }
cf93c79d 185 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 186 m = s;
187 s = orig;
cf93c79d 188 cx->sb_orig = orig = rx->subbeg;
a0d0e21e
LW		 189 s = orig + (m - s);
190 cx->sb_strend = s + (cx->sb_strend - m);
191 }
cf93c79d 192 cx->sb_m = m = rx->startp[0] + orig;
a0d0e21e 193 sv_catpvn(dstr, s, m-s);
cf93c79d 194 cx->sb_s = rx->endp[0] + orig;
d9f97599
GS		 195 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
196 rxres_save(&cx->sb_rxres, rx);
a0d0e21e
LW		 197 RETURNOP(pm->op_pmreplstart);
198}
199
c90c0ff4 200void
864dbfa3 201Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 202{
203 UV *p = (UV*)*rsp;
204 U32 i;
205
d9f97599
GS		 206 if (!p || p[1] < rx->nparens) {
207 i = 6 + rx->nparens * 2;
c90c0ff4 208 if (!p)
209 New(501, p, i, UV);
210 else
211 Renew(p, i, UV);
212 *rsp = (void*)p;
213 }
214
cf93c79d
IZ		 215 *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
216 RX_MATCH_COPIED_off(rx);
c90c0ff4 217
d9f97599 218 *p++ = rx->nparens;
c90c0ff4 219
d9f97599 220 *p++ = (UV)rx->subbeg;
cf93c79d 221 *p++ = (UV)rx->sublen;
d9f97599
GS		 222 for (i = 0; i <= rx->nparens; ++i) {
223 *p++ = (UV)rx->startp[i];
224 *p++ = (UV)rx->endp[i];
c90c0ff4 225 }
226}
227
228void
864dbfa3 229Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4 230{
231 UV *p = (UV*)*rsp;
232 U32 i;
233
cf93c79d
IZ		 234 if (RX_MATCH_COPIED(rx))
235 Safefree(rx->subbeg);
236 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4 237 *p++ = 0;
238
d9f97599 239 rx->nparens = *p++;
c90c0ff4 240
d9f97599 241 rx->subbeg = (char*)(*p++);
cf93c79d 242 rx->sublen = (I32)(*p++);
d9f97599 243 for (i = 0; i <= rx->nparens; ++i) {
cf93c79d
IZ		 244 rx->startp[i] = (I32)(*p++);
245 rx->endp[i] = (I32)(*p++);
c90c0ff4 246 }
247}
248
249void
864dbfa3 250Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4 251{
252 UV *p = (UV*)*rsp;
253
254 if (p) {
255 Safefree((char*)(*p));
256 Safefree(p);
257 *rsp = Null(void*);
258 }
259}
260
a0d0e21e
LW		 261PP(pp_formline)
262{
4e35701f 263 djSP; dMARK; dORIGMARK;
76e3520e 264 register SV *tmpForm = *++MARK;
a0d0e21e
LW		 265 register U16 *fpc;
266 register char *t;
267 register char *f;
268 register char *s;
269 register char *send;
270 register I32 arg;
271 register SV *sv;
272 char *item;
273 I32 itemsize;
274 I32 fieldsize;
275 I32 lines = 0;
3280af22 276 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
a0d0e21e
LW		 277 char *chophere;
278 char *linemark;
65202027 279 NV value;
a0d0e21e
LW		 280 bool gotsome;
281 STRLEN len;
a0ed51b3 282 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
a0d0e21e 283
76e3520e
GS		 284 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
285 SvREADONLY_off(tmpForm);
286 doparseform(tmpForm);
a0d0e21e
LW		 287 }
288
3280af22 289 SvPV_force(PL_formtarget, len);
a0ed51b3 290 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 291 t += len;
76e3520e 292 f = SvPV(tmpForm, len);
a0d0e21e 293 /* need to jump to the next word */
76e3520e 294 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
a0d0e21e
LW		 295
296 fpc = (U16*)s;
297
298 for (;;) {
299 DEBUG_f( {
300 char *name = "???";
301 arg = -1;
302 switch (*fpc) {
303 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
304 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
305 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
306 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
307 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
308
309 case FF_CHECKNL: name = "CHECKNL"; break;
310 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
311 case FF_SPACE: name = "SPACE"; break;
312 case FF_HALFSPACE: name = "HALFSPACE"; break;
313 case FF_ITEM: name = "ITEM"; break;
314 case FF_CHOP: name = "CHOP"; break;
315 case FF_LINEGLOB: name = "LINEGLOB"; break;
316 case FF_NEWLINE: name = "NEWLINE"; break;
317 case FF_MORE: name = "MORE"; break;
318 case FF_LINEMARK: name = "LINEMARK"; break;
319 case FF_END: name = "END"; break;
320 }
321 if (arg >= 0)
760ac839 322 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
a0d0e21e 323 else
760ac839 324 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
a0d0e21e
LW		 325 } )
326 switch (*fpc++) {
327 case FF_LINEMARK:
328 linemark = t;
a0d0e21e
LW		 329 lines++;
330 gotsome = FALSE;
331 break;
332
333 case FF_LITERAL:
334 arg = *fpc++;
335 while (arg--)
336 *t++ = *f++;
337 break;
338
339 case FF_SKIP:
340 f += *fpc++;
341 break;
342
343 case FF_FETCH:
344 arg = *fpc++;
345 f += arg;
346 fieldsize = arg;
347
348 if (MARK < SP)
349 sv = *++MARK;
350 else {
3280af22 351 sv = &PL_sv_no;
599cee73 352 if (ckWARN(WARN_SYNTAX))
cea2e8a9 353 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
a0d0e21e
LW		 354 }
355 break;
356
357 case FF_CHECKNL:
358 item = s = SvPV(sv, len);
359 itemsize = len;
a0ed51b3
LW		 360 if (IN_UTF8) {
361 itemsize = sv_len_utf8(sv);
362 if (itemsize != len) {
363 I32 itembytes;
364 if (itemsize > fieldsize) {
365 itemsize = fieldsize;
366 itembytes = itemsize;
367 sv_pos_u2b(sv, &itembytes, 0);
368 }
369 else
370 itembytes = len;
371 send = chophere = s + itembytes;
372 while (s < send) {
373 if (*s & ~31)
374 gotsome = TRUE;
375 else if (*s == '\n')
376 break;
377 s++;
378 }
379 itemsize = s - item;
380 sv_pos_b2u(sv, &itemsize);
381 break;
382 }
383 }
a0d0e21e
LW		 384 if (itemsize > fieldsize)
385 itemsize = fieldsize;
386 send = chophere = s + itemsize;
387 while (s < send) {
388 if (*s & ~31)
389 gotsome = TRUE;
390 else if (*s == '\n')
391 break;
392 s++;
393 }
394 itemsize = s - item;
395 break;
396
397 case FF_CHECKCHOP:
398 item = s = SvPV(sv, len);
399 itemsize = len;
a0ed51b3
LW		 400 if (IN_UTF8) {
401 itemsize = sv_len_utf8(sv);
402 if (itemsize != len) {
403 I32 itembytes;
404 if (itemsize <= fieldsize) {
405 send = chophere = s + itemsize;
406 while (s < send) {
407 if (*s == '\r') {
408 itemsize = s - item;
409 break;
410 }
411 if (*s++ & ~31)
412 gotsome = TRUE;
413 }
414 }
415 else {
416 itemsize = fieldsize;
417 itembytes = itemsize;
418 sv_pos_u2b(sv, &itembytes, 0);
419 send = chophere = s + itembytes;
420 while (s < send || (s == send && isSPACE(*s))) {
421 if (isSPACE(*s)) {
422 if (chopspace)
423 chophere = s;
424 if (*s == '\r')
425 break;
426 }
427 else {
428 if (*s & ~31)
429 gotsome = TRUE;
430 if (strchr(PL_chopset, *s))
431 chophere = s + 1;
432 }
433 s++;
434 }
435 itemsize = chophere - item;
436 sv_pos_b2u(sv, &itemsize);
437 }
438 break;
439 }
440 }
a0d0e21e
LW		 441 if (itemsize <= fieldsize) {
442 send = chophere = s + itemsize;
443 while (s < send) {
444 if (*s == '\r') {
445 itemsize = s - item;
446 break;
447 }
448 if (*s++ & ~31)
449 gotsome = TRUE;
450 }
451 }
452 else {
453 itemsize = fieldsize;
454 send = chophere = s + itemsize;
455 while (s < send || (s == send && isSPACE(*s))) {
456 if (isSPACE(*s)) {
457 if (chopspace)
458 chophere = s;
459 if (*s == '\r')
460 break;
461 }
462 else {
463 if (*s & ~31)
464 gotsome = TRUE;
3280af22 465 if (strchr(PL_chopset, *s))
a0d0e21e
LW		 466 chophere = s + 1;
467 }
468 s++;
469 }
470 itemsize = chophere - item;
471 }
472 break;
473
474 case FF_SPACE:
475 arg = fieldsize - itemsize;
476 if (arg) {
477 fieldsize -= arg;
478 while (arg-- > 0)
479 *t++ = ' ';
480 }
481 break;
482
483 case FF_HALFSPACE:
484 arg = fieldsize - itemsize;
485 if (arg) {
486 arg /= 2;
487 fieldsize -= arg;
488 while (arg-- > 0)
489 *t++ = ' ';
490 }
491 break;
492
493 case FF_ITEM:
494 arg = itemsize;
495 s = item;
a0ed51b3
LW		 496 if (IN_UTF8) {
497 while (arg--) {
498 if (*s & 0x80) {
499 switch (UTF8SKIP(s)) {
500 case 7: *t++ = *s++;
501 case 6: *t++ = *s++;
502 case 5: *t++ = *s++;
503 case 4: *t++ = *s++;
504 case 3: *t++ = *s++;
505 case 2: *t++ = *s++;
506 case 1: *t++ = *s++;
507 }
508 }
509 else {
510 if ( !((*t++ = *s++) & ~31) )
511 t[-1] = ' ';
512 }
513 }
514 break;
515 }
a0d0e21e 516 while (arg--) {
9d116dd7 517#ifdef EBCDIC
a0d0e21e 518 int ch = *t++ = *s++;
9d116dd7 519 if (iscntrl(ch))
a0d0e21e
LW		 520#else
521 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 522#endif
9d116dd7 523 t[-1] = ' ';
a0d0e21e
LW		 524 }
525 break;
526
527 case FF_CHOP:
528 s = chophere;
529 if (chopspace) {
530 while (*s && isSPACE(*s))
531 s++;
532 }
533 sv_chop(sv,s);
534 break;
535
536 case FF_LINEGLOB:
537 item = s = SvPV(sv, len);
538 itemsize = len;
539 if (itemsize) {
540 gotsome = TRUE;
541 send = s + itemsize;
542 while (s < send) {
543 if (*s++ == '\n') {
544 if (s == send)
545 itemsize--;
546 else
547 lines++;
548 }
549 }
3280af22
NIS		 550 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
551 sv_catpvn(PL_formtarget, item, itemsize);
a0ed51b3 552 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
3280af22 553 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
a0d0e21e
LW		 554 }
555 break;
556
557 case FF_DECIMAL:
558 /* If the field is marked with ^ and the value is undefined,
559 blank it out. */
560 arg = *fpc++;
561 if ((arg & 512) && !SvOK(sv)) {
562 arg = fieldsize;
563 while (arg--)
564 *t++ = ' ';
565 break;
566 }
567 gotsome = TRUE;
568 value = SvNV(sv);
bbce6d69 569 /* Formats aren't yet marked for locales, so assume "yes". */
097ee67d
JH		 570 {
571 RESTORE_NUMERIC_LOCAL();
65202027
DS		 572#if defined(USE_LONG_DOUBLE)
573 if (arg & 256) {
574 sprintf(t, "%#*.*Lf",
575 (int) fieldsize, (int) arg & 255, value);
576 } else {
577 sprintf(t, "%*.0Lf", (int) fieldsize, value);
578 }
579#else
097ee67d
JH		 580 if (arg & 256) {
581 sprintf(t, "%#*.*f",
582 (int) fieldsize, (int) arg & 255, value);
583 } else {
584 sprintf(t, "%*.0f",
585 (int) fieldsize, value);
586 }
65202027 587#endif
097ee67d 588 RESTORE_NUMERIC_STANDARD();
a0d0e21e
LW		 589 }
590 t += fieldsize;
591 break;
592
593 case FF_NEWLINE:
594 f++;
595 while (t-- > linemark && *t == ' ') ;
596 t++;
597 *t++ = '\n';
598 break;
599
600 case FF_BLANK:
601 arg = *fpc++;
602 if (gotsome) {
603 if (arg) { /* repeat until fields exhausted? */
604 *t = '\0';
3280af22
NIS		 605 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
606 lines += FmLINES(PL_formtarget);
a0d0e21e
LW		 607 if (lines == 200) {
608 arg = t - linemark;
609 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 610 DIE(aTHX_ "Runaway format");
a0d0e21e 611 }
3280af22 612 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW		 613 SP = ORIGMARK;
614 RETURNOP(cLISTOP->op_first);
615 }
616 }
617 else {
618 t = linemark;
619 lines--;
620 }
621 break;
622
623 case FF_MORE:
7056ecde
KM		 624 s = chophere;
625 send = item + len;
626 if (chopspace) {
627 while (*s && isSPACE(*s) && s < send)
628 s++;
629 }
630 if (s < send) {
a0d0e21e
LW		 631 arg = fieldsize - itemsize;
632 if (arg) {
633 fieldsize -= arg;
634 while (arg-- > 0)
635 *t++ = ' ';
636 }
637 s = t - 3;
638 if (strnEQ(s," ",3)) {
3280af22 639 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
a0d0e21e
LW		 640 s--;
641 }
642 *s++ = '.';
643 *s++ = '.';
644 *s++ = '.';
645 }
646 break;
647
648 case FF_END:
649 *t = '\0';
3280af22
NIS		 650 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
651 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW		 652 SP = ORIGMARK;
653 RETPUSHYES;
654 }
655 }
656}
657
658PP(pp_grepstart)
659{
4e35701f 660 djSP;
a0d0e21e
LW		 661 SV *src;
662
3280af22 663 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 664 (void)POPMARK;
54310121 665 if (GIMME_V == G_SCALAR)
0b024f31 666 XPUSHs(sv_2mortal(newSViv(0)));
533c011a 667 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 668 }
3280af22 669 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS		 670 pp_pushmark(); /* push dst */
671 pp_pushmark(); /* push src */
a0d0e21e
LW		 672 ENTER; /* enter outer scope */
673
674 SAVETMPS;
127ad2b7
GS		 675 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
676 SAVESPTR(DEFSV);
a0d0e21e 677 ENTER; /* enter inner scope */
3280af22 678 SAVESPTR(PL_curpm);
a0d0e21e 679
3280af22 680 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 681 SvTEMP_off(src);
54b9620d 682 DEFSV = src;
a0d0e21e
LW		 683
684 PUTBACK;
533c011a 685 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 686 pp_pushmark(); /* push top */
533c011a 687 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW		 688}
689
690PP(pp_mapstart)
691{
cea2e8a9 692 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
a0d0e21e
LW		 693}
694
695PP(pp_mapwhile)
696{
4e35701f 697 djSP;
3280af22 698 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
a0d0e21e
LW		 699 I32 count;
700 I32 shift;
701 SV** src;
702 SV** dst;
703
3280af22 704 ++PL_markstack_ptr[-1];
a0d0e21e 705 if (diff) {
3280af22
NIS		 706 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
707 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
708 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
a0d0e21e 709
924508f0
GS		 710 EXTEND(SP,shift);
711 src = SP;
712 dst = (SP += shift);
3280af22
NIS		 713 PL_markstack_ptr[-1] += shift;
714 *PL_markstack_ptr += shift;
a0d0e21e
LW		 715 while (--count)
716 *dst-- = *src--;
717 }
3280af22 718 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
a0d0e21e
LW		 719 ++diff;
720 while (--diff)
721 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
722 }
723 LEAVE; /* exit inner scope */
724
725 /* All done yet? */
3280af22 726 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e 727 I32 items;
54310121 728 I32 gimme = GIMME_V;
a0d0e21e
LW		 729
730 (void)POPMARK; /* pop top */
731 LEAVE; /* exit outer scope */
732 (void)POPMARK; /* pop src */
3280af22 733 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 734 (void)POPMARK; /* pop dst */
3280af22 735 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 736 if (gimme == G_SCALAR) {
a0d0e21e
LW		 737 dTARGET;
738 XPUSHi(items);
a0d0e21e 739 }
54310121 740 else if (gimme == G_ARRAY)
741 SP += items;
a0d0e21e
LW		 742 RETURN;
743 }
744 else {
745 SV *src;
746
747 ENTER; /* enter inner scope */
3280af22 748 SAVESPTR(PL_curpm);
a0d0e21e 749
3280af22 750 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 751 SvTEMP_off(src);
54b9620d 752 DEFSV = src;
a0d0e21e
LW		 753
754 RETURNOP(cLOGOP->op_other);
755 }
756}
757
9c007264 758STATIC I32
cea2e8a9 759S_sv_ncmp(pTHX_ SV *a, SV *b)
9c007264 760{
65202027
DS		 761 NV nv1 = SvNV(a);
762 NV nv2 = SvNV(b);
9c007264
JH		 763 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
764}
864dbfa3 765
9c007264 766STATIC I32
cea2e8a9 767S_sv_i_ncmp(pTHX_ SV *a, SV *b)
9c007264
JH		 768{
769 IV iv1 = SvIV(a);
770 IV iv2 = SvIV(b);
771 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
772}
d0ecd44c
IZ		 773#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
774 *svp = Nullsv; \
775 if (PL_amagic_generation) { \
776 if (SvAMAGIC(left)||SvAMAGIC(right))\
777 *svp = amagic_call(left, \
778 right, \
779 CAT2(meth,_amg), \
780 0); \
781 } \
782 } STMT_END
783
9c007264 784STATIC I32
cea2e8a9 785S_amagic_ncmp(pTHX_ register SV *a, register SV *b)
9c007264
JH		 786{
787 SV *tmpsv;
788 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
789 if (tmpsv) {
65202027 790 NV d;
9c007264
JH		 791
792 if (SvIOK(tmpsv)) {
793 I32 i = SvIVX(tmpsv);
794 if (i > 0)
795 return 1;
796 return i? -1 : 0;
797 }
798 d = SvNV(tmpsv);
799 if (d > 0)
800 return 1;
801 return d? -1 : 0;
802 }
803 return sv_ncmp(a, b);
804}
805
806STATIC I32
cea2e8a9 807S_amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
9c007264
JH		 808{
809 SV *tmpsv;
810 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
811 if (tmpsv) {
65202027 812 NV d;
9c007264
JH		 813
814 if (SvIOK(tmpsv)) {
815 I32 i = SvIVX(tmpsv);
816 if (i > 0)
817 return 1;
818 return i? -1 : 0;
819 }
820 d = SvNV(tmpsv);
821 if (d > 0)
822 return 1;
823 return d? -1 : 0;
824 }
825 return sv_i_ncmp(a, b);
826}
827
a0964cd6 828STATIC I32
cea2e8a9 829S_amagic_cmp(pTHX_ register SV *str1, register SV *str2)
d0ecd44c
IZ		 830{
831 SV *tmpsv;
832 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
833 if (tmpsv) {
65202027 834 NV d;
d0ecd44c
IZ		 835
836 if (SvIOK(tmpsv)) {
837 I32 i = SvIVX(tmpsv);
838 if (i > 0)
839 return 1;
840 return i? -1 : 0;
841 }
842 d = SvNV(tmpsv);
843 if (d > 0)
844 return 1;
845 return d? -1 : 0;
846 }
847 return sv_cmp(str1, str2);
848}
849
a0964cd6 850STATIC I32
cea2e8a9 851S_amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
d0ecd44c
IZ		 852{
853 SV *tmpsv;
854 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
855 if (tmpsv) {
65202027 856 NV d;
d0ecd44c
IZ		 857
858 if (SvIOK(tmpsv)) {
859 I32 i = SvIVX(tmpsv);
860 if (i > 0)
861 return 1;
862 return i? -1 : 0;
863 }
864 d = SvNV(tmpsv);
865 if (d > 0)
866 return 1;
867 return d? -1 : 0;
868 }
869 return sv_cmp_locale(str1, str2);
870}
871
a0d0e21e
LW		 872PP(pp_sort)
873{
4e35701f 874 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 875 register SV **up;
876 SV **myorigmark = ORIGMARK;
877 register I32 max;
878 HV *stash;
879 GV *gv;
880 CV *cv;
881 I32 gimme = GIMME;
533c011a 882 OP* nextop = PL_op->op_next;
d0ecd44c 883 I32 overloading = 0;
a0d0e21e
LW		 884
885 if (gimme != G_ARRAY) {
886 SP = MARK;
887 RETPUSHUNDEF;
888 }
889
d0abe6c5 890 ENTER;
3280af22 891 SAVEPPTR(PL_sortcop);
533c011a
NIS		 892 if (PL_op->op_flags & OPf_STACKED) {
893 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 894 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
895 kid = kUNOP->op_first; /* pass rv2gv */
896 kid = kUNOP->op_first; /* pass leave */
3280af22
NIS		 897 PL_sortcop = kid->op_next;
898 stash = PL_curcop->cop_stash;
a0d0e21e
LW		 899 }
900 else {
901 cv = sv_2cv(*++MARK, &stash, &gv, 0);
902 if (!(cv && CvROOT(cv))) {
903 if (gv) {
904 SV *tmpstr = sv_newmortal();
e5cf08de 905 gv_efullname3(tmpstr, gv, Nullch);
a0d0e21e 906 if (cv && CvXSUB(cv))
cea2e8a9
GS		 907 DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
908 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
a0d0e21e
LW		 909 SvPVX(tmpstr));
910 }
911 if (cv) {
912 if (CvXSUB(cv))
cea2e8a9
GS		 913 DIE(aTHX_ "Xsub called in sort");
914 DIE(aTHX_ "Undefined subroutine in sort");
a0d0e21e 915 }
cea2e8a9 916 DIE(aTHX_ "Not a CODE reference in sort");
a0d0e21e 917 }
3280af22 918 PL_sortcop = CvSTART(cv);
a0d0e21e 919 SAVESPTR(CvROOT(cv)->op_ppaddr);
22c35a8c 920 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
b3933176 921
3280af22
NIS		 922 SAVESPTR(PL_curpad);
923 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
a0d0e21e
LW		 924 }
925 }
926 else {
3280af22
NIS		 927 PL_sortcop = Nullop;
928 stash = PL_curcop->cop_stash;
a0d0e21e
LW		 929 }
930
931 up = myorigmark + 1;
932 while (MARK < SP) { /* This may or may not shift down one here. */
933 /*SUPPRESS 560*/
934 if (*up = *++MARK) { /* Weed out nulls. */
9f8d30d5 935 SvTEMP_off(*up);
d0ecd44c 936 if (!PL_sortcop && !SvPOK(*up)) {
2d8e6c8d 937 STRLEN n_a;
d0ecd44c
IZ		 938 if (SvAMAGIC(*up))
939 overloading = 1;
940 else
2d8e6c8d 941 (void)sv_2pv(*up, &n_a);
d0ecd44c 942 }
a0d0e21e
LW		 943 up++;
944 }
945 }
946 max = --up - myorigmark;
3280af22 947 if (PL_sortcop) {
a0d0e21e 948 if (max > 1) {
c09156bb 949 PERL_CONTEXT *cx;
a0d0e21e 950 SV** newsp;
54310121 951 bool oldcatch = CATCH_GET;
a0d0e21e
LW		 952
953 SAVETMPS;
462e5cf6 954 SAVEOP();
a0d0e21e 955
54310121 956 CATCH_SET(TRUE);
e788e7d3 957 PUSHSTACKi(PERLSI_SORT);
3280af22
NIS		 958 if (PL_sortstash != stash) {
959 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
960 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
961 PL_sortstash = stash;
a0d0e21e
LW		 962 }
963
3280af22
NIS		 964 SAVESPTR(GvSV(PL_firstgv));
965 SAVESPTR(GvSV(PL_secondgv));
b3933176 966
3280af22 967 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
533c011a 968 if (!(PL_op->op_flags & OPf_SPECIAL)) {
b3933176
CS		 969 bool hasargs = FALSE;
970 cx->cx_type = CXt_SUB;
971 cx->blk_gimme = G_SCALAR;
972 PUSHSUB(cx);
973 if (!CvDEPTH(cv))
3e3baf6d 974 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
b3933176 975 }
3280af22 976 PL_sortcxix = cxstack_ix;
cea2e8a9 977 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(S_sortcv));
a0d0e21e 978
3280af22 979 POPBLOCK(cx,PL_curpm);
ebafeae7 980 PL_stack_sp = newsp;
d3acc0f7 981 POPSTACK;
54310121 982 CATCH_SET(oldcatch);
a0d0e21e 983 }
a0d0e21e
LW		 984 }
985 else {
986 if (max > 1) {
987 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
745d3a65 988 qsortsv(ORIGMARK+1, max,
9c007264
JH		 989 (PL_op->op_private & OPpSORT_NUMERIC)
990 ? ( (PL_op->op_private & OPpSORT_INTEGER)
991 ? ( overloading
cea2e8a9
GS		 992 ? FUNC_NAME_TO_PTR(S_amagic_i_ncmp)
993 : FUNC_NAME_TO_PTR(S_sv_i_ncmp))
9c007264 994 : ( overloading
cea2e8a9
GS		 995 ? FUNC_NAME_TO_PTR(S_amagic_ncmp)
996 : FUNC_NAME_TO_PTR(S_sv_ncmp)))
9c007264
JH		 997 : ( (PL_op->op_private & OPpLOCALE)
998 ? ( overloading
cea2e8a9
GS		 999 ? FUNC_NAME_TO_PTR(S_amagic_cmp_locale)
1000 : FUNC_NAME_TO_PTR(Perl_sv_cmp_locale))
9c007264 1001 : ( overloading
cea2e8a9
GS		 1002 ? FUNC_NAME_TO_PTR(S_amagic_cmp)
1003 : FUNC_NAME_TO_PTR(Perl_sv_cmp) )));
9c007264
JH		 1004 if (PL_op->op_private & OPpSORT_REVERSE) {
1005 SV **p = ORIGMARK+1;
1006 SV **q = ORIGMARK+max;
1007 while (p < q) {
1008 SV *tmp = *p;
1009 *p++ = *q;
1010 *q-- = tmp;
1011 }
1012 }
a0d0e21e
LW		 1013 }
1014 }
d0abe6c5 1015 LEAVE;
3280af22 1016 PL_stack_sp = ORIGMARK + max;
a0d0e21e
LW		 1017 return nextop;
1018}
1019
1020/* Range stuff. */
1021
1022PP(pp_range)
1023{
1024 if (GIMME == G_ARRAY)
1025 return cCONDOP->op_true;
538573f7
GS		 1026 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1027 return cCONDOP->op_false;
1028 else
1029 return cCONDOP->op_true;
a0d0e21e
LW		 1030}
1031
1032PP(pp_flip)
1033{
4e35701f 1034 djSP;
a0d0e21e
LW		 1035
1036 if (GIMME == G_ARRAY) {
1037 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1038 }
1039 else {
1040 dTOPss;
533c011a 1041 SV *targ = PAD_SV(PL_op->op_targ);
a0d0e21e 1042
533c011a 1043 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1044 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW		 1045 : SvTRUE(sv) ) {
1046 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1047 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1048 sv_setiv(targ, 1);
3e3baf6d 1049 SETs(targ);
a0d0e21e
LW		 1050 RETURN;
1051 }
1052 else {
1053 sv_setiv(targ, 0);
924508f0 1054 SP--;
a0d0e21e
LW		 1055 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1056 }
1057 }
1058 sv_setpv(TARG, "");
1059 SETs(targ);
1060 RETURN;
1061 }
1062}
1063
1064PP(pp_flop)
1065{
4e35701f 1066 djSP;
a0d0e21e
LW		 1067
1068 if (GIMME == G_ARRAY) {
1069 dPOPPOPssrl;
c1ab3db2 1070 register I32 i, j;
a0d0e21e
LW		 1071 register SV *sv;
1072 I32 max;
86cb7173
HS		 1073
1074 if (SvGMAGICAL(left))
1075 mg_get(left);
1076 if (SvGMAGICAL(right))
1077 mg_get(right);
a0d0e21e 1078
4633a7c4 1079 if (SvNIOKp(left) || !SvPOKp(left) ||
bbce6d69 1080 (looks_like_number(left) && *SvPVX(left) != '0') )
1081 {
c1ab3db2 1082 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
cea2e8a9 1083 Perl_croak(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW		 1084 i = SvIV(left);
1085 max = SvIV(right);
bbce6d69 1086 if (max >= i) {
c1ab3db2
AK		 1087 j = max - i + 1;
1088 EXTEND_MORTAL(j);
1089 EXTEND(SP, j);
bbce6d69 1090 }
c1ab3db2
AK		 1091 else
1092 j = 0;
1093 while (j--) {
bbce6d69 1094 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW		 1095 PUSHs(sv);
1096 }
1097 }
1098 else {
1099 SV *final = sv_mortalcopy(right);
2d8e6c8d 1100 STRLEN len, n_a;
a0d0e21e
LW		 1101 char *tmps = SvPV(final, len);
1102
1103 sv = sv_mortalcopy(left);
2d8e6c8d 1104 SvPV_force(sv,n_a);
89ea2908 1105 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1106 XPUSHs(sv);
89ea2908
GA		 1107 if (strEQ(SvPVX(sv),tmps))
1108 break;
a0d0e21e
LW		 1109 sv = sv_2mortal(newSVsv(sv));
1110 sv_inc(sv);
1111 }
a0d0e21e
LW		 1112 }
1113 }
1114 else {
1115 dTOPss;
1116 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1117 sv_inc(targ);
533c011a 1118 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1119 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW		 1120 : SvTRUE(sv) ) {
1121 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1122 sv_catpv(targ, "E0");
1123 }
1124 SETs(targ);
1125 }
1126
1127 RETURN;
1128}
1129
1130/* Control. */
1131
76e3520e 1132STATIC I32
cea2e8a9 1133S_dopoptolabel(pTHX_ char *label)
a0d0e21e 1134{
11343788 1135 dTHR;
a0d0e21e 1136 register I32 i;
c09156bb 1137 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1138
1139 for (i = cxstack_ix; i >= 0; i--) {
1140 cx = &cxstack[i];
6b35e009 1141 switch (CxTYPE(cx)) {
a0d0e21e 1142 case CXt_SUBST:
599cee73 1143 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1144 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1145 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1146 break;
1147 case CXt_SUB:
599cee73 1148 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1149 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1150 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1151 break;
1152 case CXt_EVAL:
599cee73 1153 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1154 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1155 PL_op_name[PL_op->op_type]);
a0d0e21e 1156 break;
0a753a76 1157 case CXt_NULL:
599cee73 1158 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1159 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1160 PL_op_name[PL_op->op_type]);
0a753a76 1161 return -1;
a0d0e21e
LW		 1162 case CXt_LOOP:
1163 if (!cx->blk_loop.label ||
1164 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1165 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1166 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1167 continue;
1168 }
cea2e8a9 1169 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1170 return i;
1171 }
1172 }
1173 return i;
1174}
1175
e50aee73 1176I32
864dbfa3 1177Perl_dowantarray(pTHX)
e50aee73 1178{
54310121 1179 I32 gimme = block_gimme();
1180 return (gimme == G_VOID) ? G_SCALAR : gimme;
1181}
1182
1183I32
864dbfa3 1184Perl_block_gimme(pTHX)
54310121 1185{
11343788 1186 dTHR;
e50aee73
AD		 1187 I32 cxix;
1188
1189 cxix = dopoptosub(cxstack_ix);
1190 if (cxix < 0)
46fc3d4c 1191 return G_VOID;
e50aee73 1192
54310121 1193 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1194 case G_VOID:
1195 return G_VOID;
54310121 1196 case G_SCALAR:
e50aee73 1197 return G_SCALAR;
54310121 1198 case G_ARRAY:
1199 return G_ARRAY;
1200 default:
cea2e8a9 1201 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1202 /* NOTREACHED */
1203 return 0;
54310121 1204 }
e50aee73
AD		 1205}
1206
76e3520e 1207STATIC I32
cea2e8a9 1208S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1209{
11343788 1210 dTHR;
2c375eb9
GS		 1211 return dopoptosub_at(cxstack, startingblock);
1212}
1213
1214STATIC I32
cea2e8a9 1215S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9
GS		 1216{
1217 dTHR;
a0d0e21e 1218 I32 i;
c09156bb 1219 register PERL_CONTEXT *cx;
a0d0e21e 1220 for (i = startingblock; i >= 0; i--) {
2c375eb9 1221 cx = &cxstk[i];
6b35e009 1222 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1223 default:
1224 continue;
1225 case CXt_EVAL:
1226 case CXt_SUB:
cea2e8a9 1227 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1228 return i;
1229 }
1230 }
1231 return i;
1232}
1233
76e3520e 1234STATIC I32
cea2e8a9 1235S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1236{
11343788 1237 dTHR;
a0d0e21e 1238 I32 i;
c09156bb 1239 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1240 for (i = startingblock; i >= 0; i--) {
1241 cx = &cxstack[i];
6b35e009 1242 switch (CxTYPE(cx)) {
a0d0e21e
LW		 1243 default:
1244 continue;
1245 case CXt_EVAL:
cea2e8a9 1246 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1247 return i;
1248 }
1249 }
1250 return i;
1251}
1252
76e3520e 1253STATIC I32
cea2e8a9 1254S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1255{
11343788 1256 dTHR;
a0d0e21e 1257 I32 i;
c09156bb 1258 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1259 for (i = startingblock; i >= 0; i--) {
1260 cx = &cxstack[i];
6b35e009 1261 switch (CxTYPE(cx)) {
a0d0e21e 1262 case CXt_SUBST:
599cee73 1263 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1264 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1265 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1266 break;
1267 case CXt_SUB:
599cee73 1268 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1269 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1270 PL_op_name[PL_op->op_type]);
a0d0e21e
LW		 1271 break;
1272 case CXt_EVAL:
599cee73 1273 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1274 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1275 PL_op_name[PL_op->op_type]);
a0d0e21e 1276 break;
0a753a76 1277 case CXt_NULL:
599cee73 1278 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1279 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1280 PL_op_name[PL_op->op_type]);
0a753a76 1281 return -1;
a0d0e21e 1282 case CXt_LOOP:
cea2e8a9 1283 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1284 return i;
1285 }
1286 }
1287 return i;
1288}
1289
1290void
864dbfa3 1291Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1292{
11343788 1293 dTHR;
c09156bb 1294 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1295 SV **newsp;
1296 I32 optype;
1297
1298 while (cxstack_ix > cxix) {
c90c0ff4 1299 cx = &cxstack[cxstack_ix];
1300 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1301 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1302 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1303 switch (CxTYPE(cx)) {
c90c0ff4 1304 case CXt_SUBST:
1305 POPSUBST(cx);
1306 continue; /* not break */
a0d0e21e
LW		 1307 case CXt_SUB:
1308 POPSUB(cx);
1309 break;
1310 case CXt_EVAL:
1311 POPEVAL(cx);
1312 break;
1313 case CXt_LOOP:
1314 POPLOOP(cx);
1315 break;
0a753a76 1316 case CXt_NULL:
a0d0e21e
LW		 1317 break;
1318 }
c90c0ff4 1319 cxstack_ix--;
a0d0e21e
LW		 1320 }
1321}
1322
067f92a0
GS		 1323/*
1324 * Closures mentioned at top level of eval cannot be referenced
1325 * again, and their presence indirectly causes a memory leak.
1326 * (Note that the fact that compcv and friends are still set here
1327 * is, AFAIK, an accident.) --Chip
1328 *
1329 * XXX need to get comppad et al from eval's cv rather than
1330 * relying on the incidental global values.
1331 */
1332STATIC void
cea2e8a9 1333S_free_closures(pTHX)
067f92a0
GS		 1334{
1335 dTHR;
1336 SV **svp = AvARRAY(PL_comppad_name);
1337 I32 ix;
1338 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1339 SV *sv = svp[ix];
1340 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1341 SvREFCNT_dec(sv);
1342 svp[ix] = &PL_sv_undef;
1343
1344 sv = PL_curpad[ix];
1345 if (CvCLONE(sv)) {
1346 SvREFCNT_dec(CvOUTSIDE(sv));
1347 CvOUTSIDE(sv) = Nullcv;
1348 }
1349 else {
1350 SvREFCNT_dec(sv);
1351 sv = NEWSV(0,0);
1352 SvPADTMP_on(sv);
1353 PL_curpad[ix] = sv;
1354 }
1355 }
1356 }
1357}
1358
a0d0e21e 1359OP *
864dbfa3 1360Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1361{
e336de0d 1362 dSP;
2d8e6c8d 1363 STRLEN n_a;
3280af22 1364 if (PL_in_eval) {
a0d0e21e 1365 I32 cxix;
c09156bb 1366 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1367 I32 gimme;
1368 SV **newsp;
1369
4e6ea2c3 1370 if (message) {
faef0170 1371 if (PL_in_eval & EVAL_KEEPERR) {
4e6ea2c3 1372 SV **svp;
4e6ea2c3 1373
06bf62c7 1374 svp = hv_fetch(ERRHV, message, msglen, TRUE);
4e6ea2c3
GS		 1375 if (svp) {
1376 if (!SvIOK(*svp)) {
1377 static char prefix[] = "\t(in cleanup) ";
1378 SV *err = ERRSV;
1379 sv_upgrade(*svp, SVt_IV);
1380 (void)SvIOK_only(*svp);
1381 if (!SvPOK(err))
1382 sv_setpv(err,"");
06bf62c7 1383 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
4e6ea2c3 1384 sv_catpvn(err, prefix, sizeof(prefix)-1);
06bf62c7 1385 sv_catpvn(err, message, msglen);
b5d92ff4 1386 if (ckWARN(WARN_UNSAFE)) {
06bf62c7 1387 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
cea2e8a9 1388 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
b5d92ff4 1389 }
4e6ea2c3
GS		 1390 }
1391 sv_inc(*svp);
4633a7c4 1392 }
4633a7c4 1393 }
4e6ea2c3 1394 else
06bf62c7 1395 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW		 1396 }
1397 else
06bf62c7 1398 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1399
3280af22 1400 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
bac4b2ad 1401 dounwind(-1);
d3acc0f7 1402 POPSTACK;
bac4b2ad 1403 }
e336de0d 1404
a0d0e21e
LW		 1405 if (cxix >= 0) {
1406 I32 optype;
1407
1408 if (cxix < cxstack_ix)
1409 dounwind(cxix);
1410
3280af22 1411 POPBLOCK(cx,PL_curpm);
6b35e009 1412 if (CxTYPE(cx) != CXt_EVAL) {
06bf62c7
GS		 1413 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1414 PerlIO_write(PerlIO_stderr(), message, msglen);
a0d0e21e
LW		 1415 my_exit(1);
1416 }
1417 POPEVAL(cx);
1418
1419 if (gimme == G_SCALAR)
3280af22
NIS		 1420 *++newsp = &PL_sv_undef;
1421 PL_stack_sp = newsp;
a0d0e21e
LW		 1422
1423 LEAVE;
748a9306 1424
7a2e2cd6 1425 if (optype == OP_REQUIRE) {
2d8e6c8d 1426 char* msg = SvPVx(ERRSV, n_a);
cea2e8a9 1427 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
7a2e2cd6 1428 }
a0d0e21e
LW		 1429 return pop_return();
1430 }
1431 }
9cc2fdd3 1432 if (!message)
06bf62c7 1433 message = SvPVx(ERRSV, msglen);
d175a3f0
GS		 1434 {
1435#ifdef USE_SFIO
1436 /* SFIO can really mess with your errno */
1437 int e = errno;
1438#endif
06bf62c7 1439 PerlIO_write(PerlIO_stderr(), message, msglen);
d175a3f0
GS		 1440 (void)PerlIO_flush(PerlIO_stderr());
1441#ifdef USE_SFIO
1442 errno = e;
1443#endif
1444 }
f86702cc 1445 my_failure_exit();
1446 /* NOTREACHED */
a0d0e21e
LW		 1447 return 0;
1448}
1449
1450PP(pp_xor)
1451{
4e35701f 1452 djSP; dPOPTOPssrl;
a0d0e21e
LW		 1453 if (SvTRUE(left) != SvTRUE(right))
1454 RETSETYES;
1455 else
1456 RETSETNO;
1457}
1458
1459PP(pp_andassign)
1460{
4e35701f 1461 djSP;
a0d0e21e
LW		 1462 if (!SvTRUE(TOPs))
1463 RETURN;
1464 else
1465 RETURNOP(cLOGOP->op_other);
1466}
1467
1468PP(pp_orassign)
1469{
4e35701f 1470 djSP;
a0d0e21e
LW		 1471 if (SvTRUE(TOPs))
1472 RETURN;
1473 else
1474 RETURNOP(cLOGOP->op_other);
1475}
1476
a0d0e21e
LW		 1477PP(pp_caller)
1478{
4e35701f 1479 djSP;
a0d0e21e 1480 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1481 register PERL_CONTEXT *cx;
2c375eb9 1482 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1483 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1484 I32 dbcxix;
54310121 1485 I32 gimme;
49d8d3a1 1486 HV *hv;
a0d0e21e
LW		 1487 SV *sv;
1488 I32 count = 0;
1489
1490 if (MAXARG)
1491 count = POPi;
f3aa04c2 1492 EXTEND(SP, 7);
a0d0e21e 1493 for (;;) {
2c375eb9
GS		 1494 /* we may be in a higher stacklevel, so dig down deeper */
1495 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1496 top_si = top_si->si_prev;
1497 ccstack = top_si->si_cxstack;
1498 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1499 }
a0d0e21e
LW		 1500 if (cxix < 0) {
1501 if (GIMME != G_ARRAY)
1502 RETPUSHUNDEF;
1503 RETURN;
1504 }
3280af22
NIS		 1505 if (PL_DBsub && cxix >= 0 &&
1506 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1507 count++;
1508 if (!count--)
1509 break;
2c375eb9 1510 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1511 }
2c375eb9
GS		 1512
1513 cx = &ccstack[cxix];
6b35e009 1514 if (CxTYPE(cx) == CXt_SUB) {
2c375eb9
GS		 1515 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1516 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1517 field below is defined for any cx. */
3280af22 1518 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1519 cx = &ccstack[dbcxix];
06a5b730 1520 }
1521
a0d0e21e 1522 if (GIMME != G_ARRAY) {
49d8d3a1
MB		 1523 hv = cx->blk_oldcop->cop_stash;
1524 if (!hv)
3280af22 1525 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1526 else {
1527 dTARGET;
1528 sv_setpv(TARG, HvNAME(hv));
1529 PUSHs(TARG);
1530 }
a0d0e21e
LW		 1531 RETURN;
1532 }
a0d0e21e 1533
49d8d3a1
MB		 1534 hv = cx->blk_oldcop->cop_stash;
1535 if (!hv)
3280af22 1536 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1537 else
1538 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
79cb57f6
GS		 1539 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1540 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
a0d0e21e
LW		 1541 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1542 if (!MAXARG)
1543 RETURN;
6b35e009 1544 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
a0d0e21e 1545 sv = NEWSV(49, 0);
2c375eb9 1546 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW		 1547 PUSHs(sv_2mortal(sv));
1548 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1549 }
1550 else {
79cb57f6 1551 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1552 PUSHs(sv_2mortal(newSViv(0)));
1553 }
54310121 1554 gimme = (I32)cx->blk_gimme;
1555 if (gimme == G_VOID)
3280af22 1556 PUSHs(&PL_sv_undef);
54310121 1557 else
1558 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1559 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1560 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1561 PUSHs(cx->blk_eval.cur_text);
3280af22 1562 PUSHs(&PL_sv_no);
06a5b730 1563 }
1564 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1565 /* Require, put the name. */
1566 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1567 PUSHs(&PL_sv_yes);
06a5b730 1568 }
4633a7c4 1569 }
6b35e009 1570 else if (CxTYPE(cx) == CXt_SUB &&
4633a7c4 1571 cx->blk_sub.hasargs &&
3280af22 1572 PL_curcop->cop_stash == PL_debstash)
4633a7c4 1573 {
a0d0e21e
LW		 1574 AV *ary = cx->blk_sub.argarray;
1575 int off = AvARRAY(ary) - AvALLOC(ary);
1576
3280af22 1577 if (!PL_dbargs) {
a0d0e21e 1578 GV* tmpgv;
3280af22 1579 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1580 SVt_PVAV)));
a5f75d66 1581 GvMULTI_on(tmpgv);
3280af22 1582 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW		 1583 }
1584
3280af22
NIS		 1585 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1586 av_extend(PL_dbargs, AvFILLp(ary) + off);
1587 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1588 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1589 }
f3aa04c2
GS		 1590 /* XXX only hints propagated via op_private are currently
1591 * visible (others are not easily accessible, since they
1592 * use the global PL_hints) */
1593 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1594 HINT_PRIVATE_MASK)));
a0d0e21e
LW		 1595 RETURN;
1596}
1597
6b6eec5b 1598STATIC I32
cea2e8a9 1599S_sortcv(pTHX_ SV *a, SV *b)
a0d0e21e 1600{
11343788 1601 dTHR;
3280af22
NIS		 1602 I32 oldsaveix = PL_savestack_ix;
1603 I32 oldscopeix = PL_scopestack_ix;
a0d0e21e 1604 I32 result;
3280af22
NIS		 1605 GvSV(PL_firstgv) = a;
1606 GvSV(PL_secondgv) = b;
1607 PL_stack_sp = PL_stack_base;
533c011a 1608 PL_op = PL_sortcop;
cea2e8a9 1609 CALLRUNOPS(aTHX);
3280af22 1610 if (PL_stack_sp != PL_stack_base + 1)
cea2e8a9 1611 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
3280af22 1612 if (!SvNIOKp(*PL_stack_sp))
cea2e8a9 1613 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
3280af22
NIS		 1614 result = SvIV(*PL_stack_sp);
1615 while (PL_scopestack_ix > oldscopeix) {
a0d0e21e
LW		 1616 LEAVE;
1617 }
748a9306 1618 leave_scope(oldsaveix);
a0d0e21e
LW		 1619 return result;
1620}
1621
a0d0e21e
LW		 1622PP(pp_reset)
1623{
4e35701f 1624 djSP;
a0d0e21e 1625 char *tmps;
2d8e6c8d 1626 STRLEN n_a;
a0d0e21e
LW		 1627
1628 if (MAXARG < 1)
1629 tmps = "";
1630 else
2d8e6c8d 1631 tmps = POPpx;
3280af22
NIS		 1632 sv_reset(tmps, PL_curcop->cop_stash);
1633 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1634 RETURN;
1635}
1636
1637PP(pp_lineseq)
1638{
1639 return NORMAL;
1640}
1641
1642PP(pp_dbstate)
1643{
533c011a 1644 PL_curcop = (COP*)PL_op;
a0d0e21e 1645 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1646 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1647 FREETMPS;
1648
533c011a 1649 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1650 {
924508f0 1651 djSP;
a0d0e21e 1652 register CV *cv;
c09156bb 1653 register PERL_CONTEXT *cx;
748a9306 1654 I32 gimme = G_ARRAY;
a0d0e21e
LW		 1655 I32 hasargs;
1656 GV *gv;
1657
3280af22 1658 gv = PL_DBgv;
a0d0e21e 1659 cv = GvCV(gv);
a0d0e21e 1660 if (!cv)
cea2e8a9 1661 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1662
3280af22 1663 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1664 return NORMAL;
748a9306 1665
4633a7c4
LW		 1666 ENTER;
1667 SAVETMPS;
1668
3280af22 1669 SAVEI32(PL_debug);
55497cff 1670 SAVESTACK_POS();
3280af22 1671 PL_debug = 0;
748a9306 1672 hasargs = 0;
924508f0 1673 SPAGAIN;
748a9306 1674
533c011a 1675 push_return(PL_op->op_next);
924508f0 1676 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW		 1677 PUSHSUB(cx);
1678 CvDEPTH(cv)++;
1679 (void)SvREFCNT_inc(cv);
3280af22
NIS		 1680 SAVESPTR(PL_curpad);
1681 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW		 1682 RETURNOP(CvSTART(cv));
1683 }
1684 else
1685 return NORMAL;
1686}
1687
1688PP(pp_scope)
1689{
1690 return NORMAL;
1691}
1692
1693PP(pp_enteriter)
1694{
4e35701f 1695 djSP; dMARK;
c09156bb 1696 register PERL_CONTEXT *cx;
54310121 1697 I32 gimme = GIMME_V;
a0d0e21e
LW		 1698 SV **svp;
1699
4633a7c4
LW		 1700 ENTER;
1701 SAVETMPS;
1702
54b9620d 1703#ifdef USE_THREADS
0214ae40
GS		 1704 if (PL_op->op_flags & OPf_SPECIAL) {
1705 dTHR;
1706 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1707 SAVEGENERICSV(*svp);
1708 *svp = NEWSV(0,0);
1709 }
a0d0e21e 1710 else
54b9620d 1711#endif /* USE_THREADS */
533c011a
NIS		 1712 if (PL_op->op_targ) {
1713 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d
MB		 1714 SAVESPTR(*svp);
1715 }
1716 else {
0214ae40
GS		 1717 svp = &GvSV((GV*)POPs); /* symbol table variable */
1718 SAVEGENERICSV(*svp);
1719 *svp = NEWSV(0,0);
54b9620d 1720 }
4633a7c4 1721
a0d0e21e
LW		 1722 ENTER;
1723
1724 PUSHBLOCK(cx, CXt_LOOP, SP);
1725 PUSHLOOP(cx, svp, MARK);
533c011a 1726 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1727 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1728 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1729 dPOPss;
1730 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1731 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1732 if (SvNV(sv) < IV_MIN ||
1733 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
cea2e8a9 1734 Perl_croak(aTHX_ "Range iterator outside integer range");
89ea2908
GA		 1735 cx->blk_loop.iterix = SvIV(sv);
1736 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1737 }
1738 else
1739 cx->blk_loop.iterlval = newSVsv(sv);
1740 }
1741 }
4633a7c4 1742 else {
3280af22
NIS		 1743 cx->blk_loop.iterary = PL_curstack;
1744 AvFILLp(PL_curstack) = SP - PL_stack_base;
1745 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1746 }
a0d0e21e
LW		 1747
1748 RETURN;
1749}
1750
1751PP(pp_enterloop)
1752{
4e35701f 1753 djSP;
c09156bb 1754 register PERL_CONTEXT *cx;
54310121 1755 I32 gimme = GIMME_V;
a0d0e21e
LW		 1756
1757 ENTER;
1758 SAVETMPS;
1759 ENTER;
1760
1761 PUSHBLOCK(cx, CXt_LOOP, SP);
1762 PUSHLOOP(cx, 0, SP);
1763
1764 RETURN;
1765}
1766
1767PP(pp_leaveloop)
1768{
4e35701f 1769 djSP;
c09156bb 1770 register PERL_CONTEXT *cx;
f86702cc 1771 struct block_loop cxloop;
a0d0e21e
LW		 1772 I32 gimme;
1773 SV **newsp;
1774 PMOP *newpm;
1775 SV **mark;
1776
1777 POPBLOCK(cx,newpm);
4fdae800 1778 mark = newsp;
f86702cc 1779 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1780
a1f49e72 1781 TAINT_NOT;
54310121 1782 if (gimme == G_VOID)
1783 ; /* do nothing */
1784 else if (gimme == G_SCALAR) {
1785 if (mark < SP)
1786 *++newsp = sv_mortalcopy(*SP);
1787 else
3280af22 1788 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1789 }
1790 else {
a1f49e72 1791 while (mark < SP) {
a0d0e21e 1792 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1793 TAINT_NOT; /* Each item is independent */
1794 }
a0d0e21e 1795 }
f86702cc 1796 SP = newsp;
1797 PUTBACK;
1798
1799 POPLOOP2(); /* Stack values are safe: release loop vars ... */
3280af22 1800 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1801
a0d0e21e
LW		 1802 LEAVE;
1803 LEAVE;
1804
f86702cc 1805 return NORMAL;
a0d0e21e
LW		 1806}
1807
1808PP(pp_return)
1809{
4e35701f 1810 djSP; dMARK;
a0d0e21e 1811 I32 cxix;
c09156bb 1812 register PERL_CONTEXT *cx;
f86702cc 1813 struct block_sub cxsub;
1814 bool popsub2 = FALSE;
a0d0e21e
LW		 1815 I32 gimme;
1816 SV **newsp;
1817 PMOP *newpm;
1818 I32 optype = 0;
1819
3280af22
NIS		 1820 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1821 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1822 if (cxstack_ix > PL_sortcxix)
1823 dounwind(PL_sortcxix);
1824 AvARRAY(PL_curstack)[1] = *SP;
1825 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1826 return 0;
1827 }
1828 }
1829
1830 cxix = dopoptosub(cxstack_ix);
1831 if (cxix < 0)
cea2e8a9 1832 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1833 if (cxix < cxstack_ix)
1834 dounwind(cxix);
1835
1836 POPBLOCK(cx,newpm);
6b35e009 1837 switch (CxTYPE(cx)) {
a0d0e21e 1838 case CXt_SUB:
f86702cc 1839 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1840 popsub2 = TRUE;
a0d0e21e
LW		 1841 break;
1842 case CXt_EVAL:
1843 POPEVAL(cx);
067f92a0
GS		 1844 if (AvFILLp(PL_comppad_name) >= 0)
1845 free_closures();
1846 lex_end();
748a9306
LW		 1847 if (optype == OP_REQUIRE &&
1848 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1849 {
54310121 1850 /* Unassume the success we assumed earlier. */
748a9306 1851 char *name = cx->blk_eval.old_name;
3280af22 1852 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 1853 DIE(aTHX_ "%s did not return a true value", name);
748a9306 1854 }
a0d0e21e
LW		 1855 break;
1856 default:
cea2e8a9 1857 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1858 }
1859
a1f49e72 1860 TAINT_NOT;
a0d0e21e 1861 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1862 if (MARK < SP) {
1863 if (popsub2) {
1864 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1865 if (SvTEMP(TOPs)) {
1866 *++newsp = SvREFCNT_inc(*SP);
1867 FREETMPS;
1868 sv_2mortal(*newsp);
1869 } else {
1870 FREETMPS;
1871 *++newsp = sv_mortalcopy(*SP);
1872 }
1873 } else
1874 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1875 } else
1876 *++newsp = sv_mortalcopy(*SP);
1877 } else
3280af22 1878 *++newsp = &PL_sv_undef;
a0d0e21e 1879 }
54310121 1880 else if (gimme == G_ARRAY) {
a1f49e72 1881 while (++MARK <= SP) {
f86702cc 1882 *++newsp = (popsub2 && SvTEMP(*MARK))
1883 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1884 TAINT_NOT; /* Each item is independent */
1885 }
a0d0e21e 1886 }
3280af22 1887 PL_stack_sp = newsp;
a0d0e21e 1888
f86702cc 1889 /* Stack values are safe: */
1890 if (popsub2) {
1891 POPSUB2(); /* release CV and @_ ... */
1892 }
3280af22 1893 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1894
a0d0e21e
LW		 1895 LEAVE;
1896 return pop_return();
1897}
1898
1899PP(pp_last)
1900{
4e35701f 1901 djSP;
a0d0e21e 1902 I32 cxix;
c09156bb 1903 register PERL_CONTEXT *cx;
f86702cc 1904 struct block_loop cxloop;
1905 struct block_sub cxsub;
1906 I32 pop2 = 0;
a0d0e21e
LW		 1907 I32 gimme;
1908 I32 optype;
1909 OP *nextop;
1910 SV **newsp;
1911 PMOP *newpm;
3280af22 1912 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 1913
533c011a 1914 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1915 cxix = dopoptoloop(cxstack_ix);
1916 if (cxix < 0)
cea2e8a9 1917 DIE(aTHX_ "Can't \"last\" outside a block");
a0d0e21e
LW		 1918 }
1919 else {
1920 cxix = dopoptolabel(cPVOP->op_pv);
1921 if (cxix < 0)
cea2e8a9 1922 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1923 }
1924 if (cxix < cxstack_ix)
1925 dounwind(cxix);
1926
1927 POPBLOCK(cx,newpm);
6b35e009 1928 switch (CxTYPE(cx)) {
a0d0e21e 1929 case CXt_LOOP:
f86702cc 1930 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1931 pop2 = CXt_LOOP;
4fdae800 1932 nextop = cxloop.last_op->op_next;
a0d0e21e 1933 break;
f86702cc 1934 case CXt_SUB:
1935 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1936 pop2 = CXt_SUB;
a0d0e21e
LW		 1937 nextop = pop_return();
1938 break;
f86702cc 1939 case CXt_EVAL:
1940 POPEVAL(cx);
a0d0e21e
LW		 1941 nextop = pop_return();
1942 break;
1943 default:
cea2e8a9 1944 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 1945 }
1946
a1f49e72 1947 TAINT_NOT;
a0d0e21e 1948 if (gimme == G_SCALAR) {
f86702cc 1949 if (MARK < SP)
1950 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1951 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1952 else
3280af22 1953 *++newsp = &PL_sv_undef;
a0d0e21e 1954 }
54310121 1955 else if (gimme == G_ARRAY) {
a1f49e72 1956 while (++MARK <= SP) {
f86702cc 1957 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1958 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1959 TAINT_NOT; /* Each item is independent */
1960 }
f86702cc 1961 }
1962 SP = newsp;
1963 PUTBACK;
1964
1965 /* Stack values are safe: */
1966 switch (pop2) {
1967 case CXt_LOOP:
1968 POPLOOP2(); /* release loop vars ... */
4fdae800 1969 LEAVE;
f86702cc 1970 break;
1971 case CXt_SUB:
1972 POPSUB2(); /* release CV and @_ ... */
1973 break;
a0d0e21e 1974 }
3280af22 1975 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1976
1977 LEAVE;
f86702cc 1978 return nextop;
a0d0e21e
LW		 1979}
1980
1981PP(pp_next)
1982{
1983 I32 cxix;
c09156bb 1984 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1985 I32 oldsave;
1986
533c011a 1987 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1988 cxix = dopoptoloop(cxstack_ix);
1989 if (cxix < 0)
cea2e8a9 1990 DIE(aTHX_ "Can't \"next\" outside a block");
a0d0e21e
LW		 1991 }
1992 else {
1993 cxix = dopoptolabel(cPVOP->op_pv);
1994 if (cxix < 0)
cea2e8a9 1995 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1996 }
1997 if (cxix < cxstack_ix)
1998 dounwind(cxix);
1999
2000 TOPBLOCK(cx);
3280af22 2001 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2002 LEAVE_SCOPE(oldsave);
2003 return cx->blk_loop.next_op;
2004}
2005
2006PP(pp_redo)
2007{
2008 I32 cxix;
c09156bb 2009 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2010 I32 oldsave;
2011
533c011a 2012 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2013 cxix = dopoptoloop(cxstack_ix);
2014 if (cxix < 0)
cea2e8a9 2015 DIE(aTHX_ "Can't \"redo\" outside a block");
a0d0e21e
LW		 2016 }
2017 else {
2018 cxix = dopoptolabel(cPVOP->op_pv);
2019 if (cxix < 0)
cea2e8a9 2020 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2021 }
2022 if (cxix < cxstack_ix)
2023 dounwind(cxix);
2024
2025 TOPBLOCK(cx);
3280af22 2026 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2027 LEAVE_SCOPE(oldsave);
2028 return cx->blk_loop.redo_op;
2029}
2030
0824fdcb 2031STATIC OP *
cea2e8a9 2032S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 2033{
2034 OP *kid;
2035 OP **ops = opstack;
fc36a67e 2036 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2037
fc36a67e 2038 if (ops >= oplimit)
cea2e8a9 2039 Perl_croak(aTHX_ too_deep);
11343788
MB		 2040 if (o->op_type == OP_LEAVE ||
2041 o->op_type == OP_SCOPE ||
2042 o->op_type == OP_LEAVELOOP ||
2043 o->op_type == OP_LEAVETRY)
fc36a67e 2044 {
5dc0d613 2045 *ops++ = cUNOPo->op_first;
fc36a67e 2046 if (ops >= oplimit)
cea2e8a9 2047 Perl_croak(aTHX_ too_deep);
fc36a67e 2048 }
a0d0e21e 2049 *ops = 0;
11343788 2050 if (o->op_flags & OPf_KIDS) {
5c0ca799 2051 dTHR;
a0d0e21e 2052 /* First try all the kids at this level, since that's likeliest. */
11343788 2053 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
a0d0e21e
LW		 2054 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2055 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2056 return kid;
2057 }
11343788 2058 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2059 if (kid == PL_lastgotoprobe)
a0d0e21e 2060 continue;
fc36a67e 2061 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2062 (ops == opstack ||
2063 (ops[-1]->op_type != OP_NEXTSTATE &&
2064 ops[-1]->op_type != OP_DBSTATE)))
2065 *ops++ = kid;
5dc0d613 2066 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 2067 return o;
a0d0e21e
LW		 2068 }
2069 }
2070 *ops = 0;
2071 return 0;
2072}
2073
2074PP(pp_dump)
2075{
cea2e8a9 2076 return pp_goto();
a0d0e21e
LW		 2077 /*NOTREACHED*/
2078}
2079
2080PP(pp_goto)
2081{
4e35701f 2082 djSP;
a0d0e21e
LW		 2083 OP *retop = 0;
2084 I32 ix;
c09156bb 2085 register PERL_CONTEXT *cx;
fc36a67e 2086#define GOTO_DEPTH 64
2087 OP *enterops[GOTO_DEPTH];
a0d0e21e 2088 char *label;
533c011a 2089 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2090 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 2091
2092 label = 0;
533c011a 2093 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2094 SV *sv = POPs;
2d8e6c8d 2095 STRLEN n_a;
a0d0e21e
LW		 2096
2097 /* This egregious kludge implements goto &subroutine */
2098 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2099 I32 cxix;
c09156bb 2100 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2101 CV* cv = (CV*)SvRV(sv);
2102 SV** mark;
2103 I32 items = 0;
2104 I32 oldsave;
62b1ebc2 2105 int arg_was_real = 0;
a0d0e21e 2106
e8f7dd13 2107 retry:
4aa0a1f7 2108 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 2109 GV *gv = CvGV(cv);
2110 GV *autogv;
2111 if (gv) {
2112 SV *tmpstr;
2113 /* autoloaded stub? */
2114 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2115 goto retry;
2116 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2117 GvNAMELEN(gv), FALSE);
2118 if (autogv && (cv = GvCV(autogv)))
2119 goto retry;
2120 tmpstr = sv_newmortal();
2121 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2122 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2123 }
cea2e8a9 2124 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2125 }
2126
a0d0e21e
LW		 2127 /* First do some returnish stuff. */
2128 cxix = dopoptosub(cxstack_ix);
2129 if (cxix < 0)
cea2e8a9 2130 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2131 if (cxix < cxstack_ix)
2132 dounwind(cxix);
2133 TOPBLOCK(cx);
6b35e009 2134 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2135 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2136 mark = PL_stack_sp;
6b35e009 2137 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2138 cx->blk_sub.hasargs) { /* put @_ back onto stack */
a0d0e21e
LW		 2139 AV* av = cx->blk_sub.argarray;
2140
93965878 2141 items = AvFILLp(av) + 1;
3280af22
NIS		 2142 PL_stack_sp++;
2143 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2144 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2145 PL_stack_sp += items;
6d4ff0d2 2146#ifndef USE_THREADS
3280af22
NIS		 2147 SvREFCNT_dec(GvAV(PL_defgv));
2148 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2149#endif /* USE_THREADS */
62b1ebc2
GS		 2150 if (AvREAL(av)) {
2151 arg_was_real = 1;
2152 AvREAL_off(av); /* so av_clear() won't clobber elts */
2153 }
4633a7c4 2154 av_clear(av);
a0d0e21e 2155 }
1fa4e549
AD		 2156 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2157 AV* av;
2158 int i;
2159#ifdef USE_THREADS
533c011a 2160 av = (AV*)PL_curpad[0];
1fa4e549 2161#else
3280af22 2162 av = GvAV(PL_defgv);
1fa4e549
AD		 2163#endif
2164 items = AvFILLp(av) + 1;
3280af22
NIS		 2165 PL_stack_sp++;
2166 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2167 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2168 PL_stack_sp += items;
1fa4e549 2169 }
6b35e009 2170 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2171 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2172 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2173 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2174 LEAVE_SCOPE(oldsave);
2175
2176 /* Now do some callish stuff. */
2177 SAVETMPS;
2178 if (CvXSUB(cv)) {
67caa1fe 2179#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2180 if (CvOLDSTYLE(cv)) {
20ce7b12 2181 I32 (*fp3)(int,int,int);
924508f0
GS		 2182 while (SP > mark) {
2183 SP[1] = SP[0];
2184 SP--;
a0d0e21e 2185 }
20ce7b12 2186 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
ecfc5424 2187 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2188 mark - PL_stack_base + 1,
ecfc5424 2189 items);
3280af22 2190 SP = PL_stack_base + items;
a0d0e21e 2191 }
67caa1fe
GS		 2192 else
2193#endif /* PERL_XSUB_OLDSTYLE */
2194 {
1fa4e549
AD		 2195 SV **newsp;
2196 I32 gimme;
2197
3280af22 2198 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 2199 /* Push a mark for the start of arglist */
2200 PUSHMARK(mark);
0cb96387 2201 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2202 /* Pop the current context like a decent sub should */
3280af22 2203 POPBLOCK(cx, PL_curpm);
1fa4e549 2204 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2205 }
2206 LEAVE;
2207 return pop_return();
2208 }
2209 else {
2210 AV* padlist = CvPADLIST(cv);
2211 SV** svp = AvARRAY(padlist);
6b35e009 2212 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2213 PL_in_eval = cx->blk_eval.old_in_eval;
2214 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2215 cx->cx_type = CXt_SUB;
2216 cx->blk_sub.hasargs = 0;
2217 }
a0d0e21e
LW		 2218 cx->blk_sub.cv = cv;
2219 cx->blk_sub.olddepth = CvDEPTH(cv);
2220 CvDEPTH(cv)++;
2221 if (CvDEPTH(cv) < 2)
2222 (void)SvREFCNT_inc(cv);
2223 else { /* save temporaries on recursion? */
599cee73 2224 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2225 sub_crush_depth(cv);
93965878 2226 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2227 AV *newpad = newAV();
4aa0a1f7 2228 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2229 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 2230 svp = AvARRAY(svp[0]);
748a9306 2231 for ( ;ix > 0; ix--) {
3280af22 2232 if (svp[ix] != &PL_sv_undef) {
748a9306 2233 char *name = SvPVX(svp[ix]);
5f05dabc 2234 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2235 || *name == '&')
2236 {
2237 /* outer lexical or anon code */
748a9306 2238 av_store(newpad, ix,
4aa0a1f7 2239 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 2240 }
2241 else { /* our own lexical */
2242 if (*name == '@')
2243 av_store(newpad, ix, sv = (SV*)newAV());
2244 else if (*name == '%')
2245 av_store(newpad, ix, sv = (SV*)newHV());
2246 else
2247 av_store(newpad, ix, sv = NEWSV(0,0));
2248 SvPADMY_on(sv);
2249 }
a0d0e21e
LW		 2250 }
2251 else {
748a9306 2252 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 2253 SvPADTMP_on(sv);
2254 }
2255 }
2256 if (cx->blk_sub.hasargs) {
2257 AV* av = newAV();
2258 av_extend(av, 0);
2259 av_store(newpad, 0, (SV*)av);
2260 AvFLAGS(av) = AVf_REIFY;
2261 }
2262 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2263 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2264 svp = AvARRAY(padlist);
2265 }
2266 }
6d4ff0d2
MB		 2267#ifdef USE_THREADS
2268 if (!cx->blk_sub.hasargs) {
533c011a 2269 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2270
93965878 2271 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2272 if (items) {
2273 /* Mark is at the end of the stack. */
924508f0
GS		 2274 EXTEND(SP, items);
2275 Copy(AvARRAY(av), SP + 1, items, SV*);
2276 SP += items;
6d4ff0d2
MB		 2277 PUTBACK ;
2278 }
2279 }
2280#endif /* USE_THREADS */
3280af22
NIS		 2281 SAVESPTR(PL_curpad);
2282 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2283#ifndef USE_THREADS
2284 if (cx->blk_sub.hasargs)
2285#endif /* USE_THREADS */
2286 {
3280af22 2287 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2288 SV** ary;
2289
6d4ff0d2 2290#ifndef USE_THREADS
3280af22
NIS		 2291 cx->blk_sub.savearray = GvAV(PL_defgv);
2292 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2293#endif /* USE_THREADS */
2294 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2295 ++mark;
2296
2297 if (items >= AvMAX(av) + 1) {
2298 ary = AvALLOC(av);
2299 if (AvARRAY(av) != ary) {
2300 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2301 SvPVX(av) = (char*)ary;
2302 }
2303 if (items >= AvMAX(av) + 1) {
2304 AvMAX(av) = items - 1;
2305 Renew(ary,items+1,SV*);
2306 AvALLOC(av) = ary;
2307 SvPVX(av) = (char*)ary;
2308 }
2309 }
2310 Copy(mark,AvARRAY(av),items,SV*);
93965878 2311 AvFILLp(av) = items - 1;
62b1ebc2
GS		 2312 /* preserve @_ nature */
2313 if (arg_was_real) {
2314 AvREIFY_off(av);
2315 AvREAL_on(av);
2316 }
a0d0e21e
LW		 2317 while (items--) {
2318 if (*mark)
2319 SvTEMP_off(*mark);
2320 mark++;
2321 }
2322 }
491527d0 2323 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2324 /*
2325 * We do not care about using sv to call CV;
2326 * it's for informational purposes only.
2327 */
3280af22 2328 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2329 CV *gotocv;
2330
2331 if (PERLDB_SUB_NN) {
2332 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2333 } else {
2334 save_item(sv);
2335 gv_efullname3(sv, CvGV(cv), Nullch);
2336 }
2337 if ( PERLDB_GOTO
864dbfa3 2338 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2339 PUSHMARK( PL_stack_sp );
864dbfa3 2340 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2341 PL_stack_sp--;
491527d0 2342 }
1ce6579f 2343 }
a0d0e21e
LW		 2344 RETURNOP(CvSTART(cv));
2345 }
2346 }
1614b0e3 2347 else {
2d8e6c8d 2348 label = SvPV(sv,n_a);
1614b0e3 2349 if (!(do_dump || *label))
cea2e8a9 2350 DIE(aTHX_ must_have_label);
1614b0e3 2351 }
a0d0e21e 2352 }
533c011a 2353 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2354 if (! do_dump)
cea2e8a9 2355 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2356 }
2357 else
2358 label = cPVOP->op_pv;
2359
2360 if (label && *label) {
2361 OP *gotoprobe = 0;
2362
2363 /* find label */
2364
3280af22 2365 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2366 *enterops = 0;
2367 for (ix = cxstack_ix; ix >= 0; ix--) {
2368 cx = &cxstack[ix];
6b35e009 2369 switch (CxTYPE(cx)) {
a0d0e21e 2370 case CXt_EVAL:
3280af22 2371 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2372 break;
2373 case CXt_LOOP:
2374 gotoprobe = cx->blk_oldcop->op_sibling;
2375 break;
2376 case CXt_SUBST:
2377 continue;
2378 case CXt_BLOCK:
2379 if (ix)
2380 gotoprobe = cx->blk_oldcop->op_sibling;
2381 else
3280af22 2382 gotoprobe = PL_main_root;
a0d0e21e 2383 break;
b3933176
CS		 2384 case CXt_SUB:
2385 if (CvDEPTH(cx->blk_sub.cv)) {
2386 gotoprobe = CvROOT(cx->blk_sub.cv);
2387 break;
2388 }
2389 /* FALL THROUGH */
0a753a76 2390 case CXt_NULL:
cea2e8a9 2391 DIE(aTHX_ "Can't \"goto\" outside a block");
a0d0e21e
LW		 2392 default:
2393 if (ix)
cea2e8a9 2394 DIE(aTHX_ "panic: goto");
3280af22 2395 gotoprobe = PL_main_root;
a0d0e21e
LW		 2396 break;
2397 }
fc36a67e 2398 retop = dofindlabel(gotoprobe, label,
2399 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW		 2400 if (retop)
2401 break;
3280af22 2402 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2403 }
2404 if (!retop)
cea2e8a9 2405 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW		 2406
2407 /* pop unwanted frames */
2408
2409 if (ix < cxstack_ix) {
2410 I32 oldsave;
2411
2412 if (ix < 0)
2413 ix = 0;
2414 dounwind(ix);
2415 TOPBLOCK(cx);
3280af22 2416 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2417 LEAVE_SCOPE(oldsave);
2418 }
2419
2420 /* push wanted frames */
2421
748a9306 2422 if (*enterops && enterops[1]) {
533c011a 2423 OP *oldop = PL_op;
748a9306 2424 for (ix = 1; enterops[ix]; ix++) {
533c011a 2425 PL_op = enterops[ix];
84902520
TB		 2426 /* Eventually we may want to stack the needed arguments
2427 * for each op. For now, we punt on the hard ones. */
533c011a 2428 if (PL_op->op_type == OP_ENTERITER)
cea2e8a9 2429 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
84902520 2430 label);
cea2e8a9 2431 (CALLOP->op_ppaddr)(aTHX);
a0d0e21e 2432 }
533c011a 2433 PL_op = oldop;
a0d0e21e
LW		 2434 }
2435 }
2436
2437 if (do_dump) {
a5f75d66 2438#ifdef VMS
6b88bc9c 2439 if (!retop) retop = PL_main_start;
a5f75d66 2440#endif
3280af22
NIS		 2441 PL_restartop = retop;
2442 PL_do_undump = TRUE;
a0d0e21e
LW		 2443
2444 my_unexec();
2445
3280af22
NIS		 2446 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2447 PL_do_undump = FALSE;
a0d0e21e
LW		 2448 }
2449
2450 RETURNOP(retop);
2451}
2452
2453PP(pp_exit)
2454{
4e35701f 2455 djSP;
a0d0e21e
LW		 2456 I32 anum;
2457
2458 if (MAXARG < 1)
2459 anum = 0;
ff0cee69 2460 else {
a0d0e21e 2461 anum = SvIVx(POPs);
ff0cee69 2462#ifdef VMSISH_EXIT
2463 if (anum == 1 && VMSISH_EXIT)
2464 anum = 0;
2465#endif
2466 }
a0d0e21e 2467 my_exit(anum);
3280af22 2468 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2469 RETURN;
2470}
2471
2472#ifdef NOTYET
2473PP(pp_nswitch)
2474{
4e35701f 2475 djSP;
65202027 2476 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2477 register I32 match = I_32(value);
2478
2479 if (value < 0.0) {
65202027 2480 if (((NV)match) > value)
a0d0e21e
LW		 2481 --match; /* was fractional--truncate other way */
2482 }
2483 match -= cCOP->uop.scop.scop_offset;
2484 if (match < 0)
2485 match = 0;
2486 else if (match > cCOP->uop.scop.scop_max)
2487 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2488 PL_op = cCOP->uop.scop.scop_next[match];
2489 RETURNOP(PL_op);
a0d0e21e
LW		 2490}
2491
2492PP(pp_cswitch)
2493{
4e35701f 2494 djSP;
a0d0e21e
LW		 2495 register I32 match;
2496
6b88bc9c
GS		 2497 if (PL_multiline)
2498 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2499 else {
2d8e6c8d
GS		 2500 STRLEN n_a;
2501 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2502 match -= cCOP->uop.scop.scop_offset;
2503 if (match < 0)
2504 match = 0;
2505 else if (match > cCOP->uop.scop.scop_max)
2506 match = cCOP->uop.scop.scop_max;
6b88bc9c 2507 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2508 }
6b88bc9c 2509 RETURNOP(PL_op);
a0d0e21e
LW		 2510}
2511#endif
2512
2513/* Eval. */
2514
0824fdcb 2515STATIC void
cea2e8a9 2516S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2517{
2518 register char *s = SvPVX(sv);
2519 register char *send = SvPVX(sv) + SvCUR(sv);
2520 register char *t;
2521 register I32 line = 1;
2522
2523 while (s && s < send) {
2524 SV *tmpstr = NEWSV(85,0);
2525
2526 sv_upgrade(tmpstr, SVt_PVMG);
2527 t = strchr(s, '\n');
2528 if (t)
2529 t++;
2530 else
2531 t = send;
2532
2533 sv_setpvn(tmpstr, s, t - s);
2534 av_store(array, line++, tmpstr);
2535 s = t;
2536 }
2537}
2538
312caa8e 2539STATIC void *
cea2e8a9 2540S_docatch_body(pTHX_ va_list args)
312caa8e 2541{
cea2e8a9 2542 CALLRUNOPS(aTHX);
312caa8e
CS		 2543 return NULL;
2544}
2545
0824fdcb 2546STATIC OP *
cea2e8a9 2547S_docatch(pTHX_ OP *o)
1e422769 2548{
e858de61 2549 dTHR;
6224f72b 2550 int ret;
533c011a 2551 OP *oldop = PL_op;
1e422769 2552
1e422769 2553#ifdef DEBUGGING
54310121 2554 assert(CATCH_GET == TRUE);
1e422769 2555#endif
312caa8e
CS		 2556 PL_op = o;
2557 redo_body:
cea2e8a9 2558 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_docatch_body));
6224f72b 2559 switch (ret) {
312caa8e
CS		 2560 case 0:
2561 break;
2562 case 3:
2563 if (PL_restartop) {
2564 PL_op = PL_restartop;
2565 PL_restartop = 0;
2566 goto redo_body;
2567 }
2568 /* FALL THROUGH */
2569 default:
533c011a 2570 PL_op = oldop;
6224f72b 2571 JMPENV_JUMP(ret);
1e422769 2572 /* NOTREACHED */
1e422769 2573 }
533c011a 2574 PL_op = oldop;
1e422769 2575 return Nullop;
2576}
2577
c277df42 2578OP *
864dbfa3 2579Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ		 2580/* sv Text to convert to OP tree. */
2581/* startop op_free() this to undo. */
2582/* code Short string id of the caller. */
2583{
2584 dSP; /* Make POPBLOCK work. */
2585 PERL_CONTEXT *cx;
2586 SV **newsp;
f987c7de 2587 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2588 I32 optype;
2589 OP dummy;
533c011a 2590 OP *oop = PL_op, *rop;
c277df42
IZ		 2591 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2592 char *safestr;
2593
2594 ENTER;
2595 lex_start(sv);
2596 SAVETMPS;
2597 /* switch to eval mode */
2598
cbce877f
IZ		 2599 if (PL_curcop == &PL_compiling) {
2600 SAVESPTR(PL_compiling.cop_stash);
2601 PL_compiling.cop_stash = PL_curstash;
2602 }
3280af22
NIS		 2603 SAVESPTR(PL_compiling.cop_filegv);
2604 SAVEI16(PL_compiling.cop_line);
2605 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2606 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2607 PL_compiling.cop_line = 1;
c277df42
IZ		 2608 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2609 deleting the eval's FILEGV from the stash before gv_check() runs
2610 (i.e. before run-time proper). To work around the coredump that
2611 ensues, we always turn GvMULTI_on for any globals that were
2612 introduced within evals. See force_ident(). GSAR 96-10-12 */
2613 safestr = savepv(tmpbuf);
3280af22 2614 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2615 SAVEHINTS();
d1ca3daa 2616#ifdef OP_IN_REGISTER
6b88bc9c 2617 PL_opsave = op;
d1ca3daa 2618#else
533c011a 2619 SAVEPPTR(PL_op);
d1ca3daa 2620#endif
3280af22 2621 PL_hints = 0;
c277df42 2622
533c011a 2623 PL_op = &dummy;
13b51b79 2624 PL_op->op_type = OP_ENTEREVAL;
533c011a 2625 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2626 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2627 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
c277df42 2628 rop = doeval(G_SCALAR, startop);
13b51b79 2629 POPBLOCK(cx,PL_curpm);
e84b9f1f 2630 POPEVAL(cx);
c277df42
IZ		 2631
2632 (*startop)->op_type = OP_NULL;
22c35a8c 2633 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2634 lex_end();
3280af22 2635 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2636 LEAVE;
13b51b79 2637 if (PL_curcop == &PL_compiling)
a0ed51b3 2638 PL_compiling.op_private = PL_hints;
d1ca3daa 2639#ifdef OP_IN_REGISTER
6b88bc9c 2640 op = PL_opsave;
d1ca3daa 2641#endif
c277df42
IZ		 2642 return rop;
2643}
2644
0f15f207 2645/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2646STATIC OP *
cea2e8a9 2647S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW		 2648{
2649 dSP;
533c011a 2650 OP *saveop = PL_op;
a0d0e21e 2651 HV *newstash;
ff3ff8d1 2652 CV *caller;
748a9306 2653 AV* comppadlist;
67a38de0 2654 I32 i;
a0d0e21e 2655
faef0170 2656 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2657
1ce6579f 2658 PUSHMARK(SP);
2659
a0d0e21e
LW		 2660 /* set up a scratch pad */
2661
3280af22
NIS		 2662 SAVEI32(PL_padix);
2663 SAVESPTR(PL_curpad);
2664 SAVESPTR(PL_comppad);
2665 SAVESPTR(PL_comppad_name);
2666 SAVEI32(PL_comppad_name_fill);
2667 SAVEI32(PL_min_intro_pending);
2668 SAVEI32(PL_max_intro_pending);
748a9306 2669
3280af22 2670 caller = PL_compcv;
6b35e009 2671 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2672 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2673 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2674 break;
6b35e009 2675 else if (CxTYPE(cx) == CXt_SUB) {
67a38de0
NIS		 2676 caller = cx->blk_sub.cv;
2677 break;
2678 }
2679 }
2680
3280af22
NIS		 2681 SAVESPTR(PL_compcv);
2682 PL_compcv = (CV*)NEWSV(1104,0);
2683 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2684 CvEVAL_on(PL_compcv);
11343788 2685#ifdef USE_THREADS
533c011a
NIS		 2686 CvOWNER(PL_compcv) = 0;
2687 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2688 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2689#endif /* USE_THREADS */
748a9306 2690
3280af22
NIS		 2691 PL_comppad = newAV();
2692 av_push(PL_comppad, Nullsv);
2693 PL_curpad = AvARRAY(PL_comppad);
2694 PL_comppad_name = newAV();
2695 PL_comppad_name_fill = 0;
2696 PL_min_intro_pending = 0;
2697 PL_padix = 0;
11343788 2698#ifdef USE_THREADS
79cb57f6 2699 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 2700 PL_curpad[0] = (SV*)newAV();
2701 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2702#endif /* USE_THREADS */
a0d0e21e 2703
748a9306
LW		 2704 comppadlist = newAV();
2705 AvREAL_off(comppadlist);
3280af22
NIS		 2706 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2707 av_store(comppadlist, 1, (SV*)PL_comppad);
2708 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2709
c277df42 2710 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2711 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2712
3280af22 2713 SAVEFREESV(PL_compcv);
748a9306 2714
a0d0e21e
LW		 2715 /* make sure we compile in the right package */
2716
3280af22
NIS		 2717 newstash = PL_curcop->cop_stash;
2718 if (PL_curstash != newstash) {
2719 SAVESPTR(PL_curstash);
2720 PL_curstash = newstash;
a0d0e21e 2721 }
3280af22
NIS		 2722 SAVESPTR(PL_beginav);
2723 PL_beginav = newAV();
2724 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2725
2726 /* try to compile it */
2727
3280af22
NIS		 2728 PL_eval_root = Nullop;
2729 PL_error_count = 0;
2730 PL_curcop = &PL_compiling;
2731 PL_curcop->cop_arybase = 0;
2732 SvREFCNT_dec(PL_rs);
79cb57f6 2733 PL_rs = newSVpvn("\n", 1);
c277df42 2734 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2735 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2736 else
38a03e6e 2737 sv_setpv(ERRSV,"");
3280af22 2738 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2739 SV **newsp;
2740 I32 gimme;
c09156bb 2741 PERL_CONTEXT *cx;
c277df42 2742 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2743 STRLEN n_a;
097ee67d 2744
533c011a 2745 PL_op = saveop;
3280af22
NIS		 2746 if (PL_eval_root) {
2747 op_free(PL_eval_root);
2748 PL_eval_root = Nullop;
a0d0e21e 2749 }
3280af22 2750 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2751 if (!startop) {
3280af22 2752 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2753 POPEVAL(cx);
2754 pop_return();
2755 }
a0d0e21e
LW		 2756 lex_end();
2757 LEAVE;
7a2e2cd6 2758 if (optype == OP_REQUIRE) {
2d8e6c8d 2759 char* msg = SvPVx(ERRSV, n_a);
cea2e8a9 2760 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
c277df42 2761 } else if (startop) {
2d8e6c8d 2762 char* msg = SvPVx(ERRSV, n_a);
c277df42 2763
3280af22 2764 POPBLOCK(cx,PL_curpm);
c277df42 2765 POPEVAL(cx);
cea2e8a9 2766 Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2767 }
3280af22
NIS		 2768 SvREFCNT_dec(PL_rs);
2769 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2770#ifdef USE_THREADS
533c011a
NIS		 2771 MUTEX_LOCK(&PL_eval_mutex);
2772 PL_eval_owner = 0;
2773 COND_SIGNAL(&PL_eval_cond);
2774 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2775#endif /* USE_THREADS */
a0d0e21e
LW		 2776 RETPUSHUNDEF;
2777 }
3280af22
NIS		 2778 SvREFCNT_dec(PL_rs);
2779 PL_rs = SvREFCNT_inc(PL_nrs);
2780 PL_compiling.cop_line = 0;
c277df42 2781 if (startop) {
3280af22
NIS		 2782 *startop = PL_eval_root;
2783 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2784 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2785 } else
3280af22 2786 SAVEFREEOP(PL_eval_root);
54310121 2787 if (gimme & G_VOID)
3280af22 2788 scalarvoid(PL_eval_root);
54310121 2789 else if (gimme & G_ARRAY)
3280af22 2790 list(PL_eval_root);
a0d0e21e 2791 else
3280af22 2792 scalar(PL_eval_root);
a0d0e21e
LW		 2793
2794 DEBUG_x(dump_eval());
2795
55497cff 2796 /* Register with debugger: */
84902520 2797 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2798 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2799 if (cv) {
2800 dSP;
924508f0 2801 PUSHMARK(SP);
3280af22 2802 XPUSHs((SV*)PL_compiling.cop_filegv);
55497cff 2803 PUTBACK;
864dbfa3 2804 call_sv((SV*)cv, G_DISCARD);
55497cff 2805 }
2806 }
2807
a0d0e21e
LW		 2808 /* compiled okay, so do it */
2809
3280af22
NIS		 2810 CvDEPTH(PL_compcv) = 1;
2811 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2812 PL_op = saveop; /* The caller may need it. */
b35b2403 2813#ifdef USE_THREADS
533c011a
NIS		 2814 MUTEX_LOCK(&PL_eval_mutex);
2815 PL_eval_owner = 0;
2816 COND_SIGNAL(&PL_eval_cond);
2817 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2818#endif /* USE_THREADS */
5dc0d613 2819
3280af22 2820 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2821}
2822
a6c40364 2823STATIC PerlIO *
cea2e8a9 2824S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2825{
2826 STRLEN namelen = strlen(name);
2827 PerlIO *fp;
2828
7894fbab 2829 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2830 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2831 char *pmc = SvPV_nolen(pmcsv);
2832 Stat_t pmstat;
a6c40364
GS		 2833 Stat_t pmcstat;
2834 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2835 fp = PerlIO_open(name, mode);
a6c40364
GS		 2836 }
2837 else {
b295d113 2838 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2839 pmstat.st_mtime < pmcstat.st_mtime)
2840 {
2841 fp = PerlIO_open(pmc, mode);
2842 }
2843 else {
2844 fp = PerlIO_open(name, mode);
2845 }
b295d113 2846 }
a6c40364
GS		 2847 SvREFCNT_dec(pmcsv);
2848 }
2849 else {
2850 fp = PerlIO_open(name, mode);
b295d113 2851 }
b295d113
TH		 2852 return fp;
2853}
2854
a0d0e21e
LW		 2855PP(pp_require)
2856{
4e35701f 2857 djSP;
c09156bb 2858 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2859 SV *sv;
2860 char *name;
6132ea6c 2861 STRLEN len;
46fc3d4c 2862 char *tryname;
2863 SV *namesv = Nullsv;
a0d0e21e
LW		 2864 SV** svp;
2865 I32 gimme = G_SCALAR;
760ac839 2866 PerlIO *tryrsfp = 0;
2d8e6c8d 2867 STRLEN n_a;
a0d0e21e
LW		 2868
2869 sv = POPs;
4633a7c4 2870 if (SvNIOKp(sv) && !SvPOKp(sv)) {
097ee67d 2871 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
cea2e8a9 2872 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2d8e6c8d 2873 SvPV(sv,n_a),PL_patchlevel);
a0d0e21e
LW		 2874 RETPUSHYES;
2875 }
6132ea6c
GS		 2876 name = SvPV(sv, len);
2877 if (!(name && len > 0 && *name))
cea2e8a9 2878 DIE(aTHX_ "Null filename used");
4633a7c4 2879 TAINT_PROPER("require");
533c011a 2880 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2881 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2882 *svp != &PL_sv_undef)
a0d0e21e
LW		 2883 RETPUSHYES;
2884
2885 /* prepare to compile file */
2886
46fc3d4c 2887 if (*name == '/' ||
2888 (*name == '.' &&
2889 (name[1] == '/' ||
2890 (name[1] == '.' && name[2] == '/')))
4633a7c4 2891#ifdef DOSISH
46fc3d4c 2892 || (name[0] && name[1] == ':')
4633a7c4 2893#endif
ba42ef2f
WJ		 2894#ifdef WIN32
2895 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2896#endif
748a9306 2897#ifdef VMS
46fc3d4c 2898 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2899 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
748a9306
LW		 2900#endif
2901 )
a0d0e21e 2902 {
46fc3d4c 2903 tryname = name;
a6c40364 2904 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2905 }
2906 else {
3280af22 2907 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2908 I32 i;
748a9306 2909#ifdef VMS
46fc3d4c 2910 char *unixname;
2911 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2912#endif
2913 {
2914 namesv = NEWSV(806, 0);
2915 for (i = 0; i <= AvFILL(ar); i++) {
2d8e6c8d 2916 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
46fc3d4c 2917#ifdef VMS
2918 char *unixdir;
2919 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2920 continue;
2921 sv_setpv(namesv, unixdir);
2922 sv_catpv(namesv, unixname);
748a9306 2923#else
cea2e8a9 2924 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 2925#endif
0cf10dd2 2926 TAINT_PROPER("require");
46fc3d4c 2927 tryname = SvPVX(namesv);
a6c40364 2928 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
46fc3d4c 2929 if (tryrsfp) {
2930 if (tryname[0] == '.' && tryname[1] == '/')
2931 tryname += 2;
2932 break;
2933 }
a0d0e21e
LW		 2934 }
2935 }
2936 }
3280af22
NIS		 2937 SAVESPTR(PL_compiling.cop_filegv);
2938 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
46fc3d4c 2939 SvREFCNT_dec(namesv);
a0d0e21e 2940 if (!tryrsfp) {
533c011a 2941 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 2942 char *msgstr = name;
2943 if (namesv) { /* did we lookup @INC? */
2944 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2945 SV *dirmsgsv = NEWSV(0, 0);
2946 AV *ar = GvAVn(PL_incgv);
2947 I32 i;
2948 sv_catpvn(msg, " in @INC", 8);
2949 if (instr(SvPVX(msg), ".h "))
2950 sv_catpv(msg, " (change .h to .ph maybe?)");
2951 if (instr(SvPVX(msg), ".ph "))
2952 sv_catpv(msg, " (did you run h2ph?)");
2953 sv_catpv(msg, " (@INC contains:");
2954 for (i = 0; i <= AvFILL(ar); i++) {
2955 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 2956 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 2957 sv_catsv(msg, dirmsgsv);
2958 }
2959 sv_catpvn(msg, ")", 1);
2960 SvREFCNT_dec(dirmsgsv);
2961 msgstr = SvPV_nolen(msg);
2683423c 2962 }
cea2e8a9 2963 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 2964 }
2965
2966 RETPUSHUNDEF;
2967 }
d8bfb8bd 2968 else
aba27d88 2969 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 2970
2971 /* Assume success here to prevent recursive requirement. */
3280af22
NIS		 2972 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2973 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
a0d0e21e
LW		 2974
2975 ENTER;
2976 SAVETMPS;
79cb57f6 2977 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 2978 SAVEGENERICSV(PL_rsfp_filters);
2979 PL_rsfp_filters = Nullav;
e50aee73 2980
3280af22 2981 PL_rsfp = tryrsfp;
a0d0e21e
LW		 2982 name = savepv(name);
2983 SAVEFREEPV(name);
b3ac6de7 2984 SAVEHINTS();
3280af22 2985 PL_hints = 0;
599cee73
PM		 2986 SAVEPPTR(PL_compiling.cop_warnings);
2987 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2988 : WARN_NONE);
a0d0e21e
LW		 2989
2990 /* switch to eval mode */
2991
533c011a 2992 push_return(PL_op->op_next);
a0d0e21e 2993 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2994 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
a0d0e21e 2995
63eb823a 2996 SAVEI16(PL_compiling.cop_line);
3280af22 2997 PL_compiling.cop_line = 0;
a0d0e21e
LW		 2998
2999 PUTBACK;
0f15f207 3000#ifdef USE_THREADS
533c011a
NIS		 3001 MUTEX_LOCK(&PL_eval_mutex);
3002 if (PL_eval_owner && PL_eval_owner != thr)
3003 while (PL_eval_owner)
3004 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3005 PL_eval_owner = thr;
3006 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3007#endif /* USE_THREADS */
c277df42 3008 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 3009}
3010
3011PP(pp_dofile)
3012{
cea2e8a9 3013 return pp_require();
a0d0e21e
LW		 3014}
3015
3016PP(pp_entereval)
3017{
4e35701f 3018 djSP;
c09156bb 3019 register PERL_CONTEXT *cx;
a0d0e21e 3020 dPOPss;
3280af22 3021 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e 3022 char tmpbuf[TYPE_DIGITS(long) + 12];
3023 char *safestr;
a0d0e21e 3024 STRLEN len;
55497cff 3025 OP *ret;
a0d0e21e
LW		 3026
3027 if (!SvPV(sv,len) || !len)
3028 RETPUSHUNDEF;
748a9306 3029 TAINT_PROPER("eval");
a0d0e21e
LW		 3030
3031 ENTER;
a0d0e21e 3032 lex_start(sv);
748a9306 3033 SAVETMPS;
a0d0e21e
LW		 3034
3035 /* switch to eval mode */
3036
3280af22
NIS		 3037 SAVESPTR(PL_compiling.cop_filegv);
3038 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3039 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3040 PL_compiling.cop_line = 1;
55497cff 3041 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3042 deleting the eval's FILEGV from the stash before gv_check() runs
3043 (i.e. before run-time proper). To work around the coredump that
3044 ensues, we always turn GvMULTI_on for any globals that were
3045 introduced within evals. See force_ident(). GSAR 96-10-12 */
3046 safestr = savepv(tmpbuf);
3280af22 3047 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3048 SAVEHINTS();
533c011a 3049 PL_hints = PL_op->op_targ;
e24b16f9 3050 SAVEPPTR(PL_compiling.cop_warnings);
599cee73
PM		 3051 if (PL_compiling.cop_warnings != WARN_ALL
3052 && PL_compiling.cop_warnings != WARN_NONE){
3053 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3054 SAVEFREESV(PL_compiling.cop_warnings) ;
3055 }
a0d0e21e 3056
533c011a 3057 push_return(PL_op->op_next);
6b35e009 3058 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
6b88bc9c 3059 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
a0d0e21e
LW		 3060
3061 /* prepare to compile string */
3062
3280af22
NIS		 3063 if (PERLDB_LINE && PL_curstash != PL_debstash)
3064 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
a0d0e21e 3065 PUTBACK;
0f15f207 3066#ifdef USE_THREADS
533c011a
NIS		 3067 MUTEX_LOCK(&PL_eval_mutex);
3068 if (PL_eval_owner && PL_eval_owner != thr)
3069 while (PL_eval_owner)
3070 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3071 PL_eval_owner = thr;
3072 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3073#endif /* USE_THREADS */
c277df42 3074 ret = doeval(gimme, NULL);
3280af22 3075 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3076 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3077 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3078 }
1e422769 3079 return DOCATCH(ret);
a0d0e21e
LW		 3080}
3081
3082PP(pp_leaveeval)
3083{
4e35701f 3084 djSP;
a0d0e21e
LW		 3085 register SV **mark;
3086 SV **newsp;
3087 PMOP *newpm;
3088 I32 gimme;
c09156bb 3089 register PERL_CONTEXT *cx;
a0d0e21e 3090 OP *retop;
533c011a 3091 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3092 I32 optype;
3093
3094 POPBLOCK(cx,newpm);
3095 POPEVAL(cx);
3096 retop = pop_return();
3097
a1f49e72 3098 TAINT_NOT;
54310121 3099 if (gimme == G_VOID)
3100 MARK = newsp;
3101 else if (gimme == G_SCALAR) {
3102 MARK = newsp + 1;
3103 if (MARK <= SP) {
3104 if (SvFLAGS(TOPs) & SVs_TEMP)
3105 *MARK = TOPs;
3106 else
3107 *MARK = sv_mortalcopy(TOPs);
3108 }
a0d0e21e 3109 else {
54310121 3110 MEXTEND(mark,0);
3280af22 3111 *MARK = &PL_sv_undef;
a0d0e21e 3112 }
a0d0e21e
LW		 3113 }
3114 else {
a1f49e72
CS		 3115 /* in case LEAVE wipes old return values */
3116 for (mark = newsp + 1; mark <= SP; mark++) {
3117 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3118 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3119 TAINT_NOT; /* Each item is independent */
3120 }
3121 }
a0d0e21e 3122 }
3280af22 3123 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3124
067f92a0
GS		 3125 if (AvFILLp(PL_comppad_name) >= 0)
3126 free_closures();
84902520 3127
4fdae800 3128#ifdef DEBUGGING
3280af22 3129 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3130#endif
3280af22 3131 CvDEPTH(PL_compcv) = 0;
f46d017c 3132 lex_end();
4fdae800 3133
1ce6579f 3134 if (optype == OP_REQUIRE &&
924508f0 3135 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3136 {
1ce6579f 3137 /* Unassume the success we assumed earlier. */
54310121 3138 char *name = cx->blk_eval.old_name;
3280af22 3139 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 3140 retop = Perl_die(aTHX_ "%s did not return a true value", name);
f46d017c
GS		 3141 /* die_where() did LEAVE, or we won't be here */
3142 }
3143 else {
3144 LEAVE;
3145 if (!(save_flags & OPf_SPECIAL))
3146 sv_setpv(ERRSV,"");
a0d0e21e 3147 }
a0d0e21e
LW		 3148
3149 RETURNOP(retop);
3150}
3151
a0d0e21e
LW		 3152PP(pp_entertry)
3153{
4e35701f 3154 djSP;
c09156bb 3155 register PERL_CONTEXT *cx;
54310121 3156 I32 gimme = GIMME_V;
a0d0e21e
LW		 3157
3158 ENTER;
3159 SAVETMPS;
3160
3161 push_return(cLOGOP->op_other->op_next);
3162 PUSHBLOCK(cx, CXt_EVAL, SP);
3163 PUSHEVAL(cx, 0, 0);
533c011a 3164 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3165
faef0170 3166 PL_in_eval = EVAL_INEVAL;
38a03e6e 3167 sv_setpv(ERRSV,"");
1e422769 3168 PUTBACK;
533c011a 3169 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3170}
3171
3172PP(pp_leavetry)
3173{
4e35701f 3174 djSP;
a0d0e21e
LW		 3175 register SV **mark;
3176 SV **newsp;
3177 PMOP *newpm;
3178 I32 gimme;
c09156bb 3179 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3180 I32 optype;
3181
3182 POPBLOCK(cx,newpm);
3183 POPEVAL(cx);
3184 pop_return();
3185
a1f49e72 3186 TAINT_NOT;
54310121 3187 if (gimme == G_VOID)
3188 SP = newsp;
3189 else if (gimme == G_SCALAR) {
3190 MARK = newsp + 1;
3191 if (MARK <= SP) {
3192 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3193 *MARK = TOPs;
3194 else
3195 *MARK = sv_mortalcopy(TOPs);
3196 }
a0d0e21e 3197 else {
54310121 3198 MEXTEND(mark,0);
3280af22 3199 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3200 }
3201 SP = MARK;
3202 }
3203 else {
a1f49e72
CS		 3204 /* in case LEAVE wipes old return values */
3205 for (mark = newsp + 1; mark <= SP; mark++) {
3206 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3207 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3208 TAINT_NOT; /* Each item is independent */
3209 }
3210 }
a0d0e21e 3211 }
3280af22 3212 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3213
3214 LEAVE;
38a03e6e 3215 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3216 RETURN;
3217}
3218
0824fdcb 3219STATIC void
cea2e8a9 3220S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3221{
3222 STRLEN len;
3223 register char *s = SvPV_force(sv, len);
3224 register char *send = s + len;
3225 register char *base;
3226 register I32 skipspaces = 0;
3227 bool noblank;
3228 bool repeat;
3229 bool postspace = FALSE;
3230 U16 *fops;
3231 register U16 *fpc;
3232 U16 *linepc;
3233 register I32 arg;
3234 bool ischop;
3235
55497cff 3236 if (len == 0)
cea2e8a9 3237 Perl_croak(aTHX_ "Null picture in formline");
55497cff 3238
3239 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3240 fpc = fops;
3241
3242 if (s < send) {
3243 linepc = fpc;
3244 *fpc++ = FF_LINEMARK;
3245 noblank = repeat = FALSE;
3246 base = s;
3247 }
3248
3249 while (s <= send) {
3250 switch (*s++) {
3251 default:
3252 skipspaces = 0;
3253 continue;
3254
3255 case '~':
3256 if (*s == '~') {
3257 repeat = TRUE;
3258 *s = ' ';
3259 }
3260 noblank = TRUE;
3261 s[-1] = ' ';
3262 /* FALL THROUGH */
3263 case ' ': case '\t':
3264 skipspaces++;
3265 continue;
3266
3267 case '\n': case 0:
3268 arg = s - base;
3269 skipspaces++;
3270 arg -= skipspaces;
3271 if (arg) {
5f05dabc 3272 if (postspace)
a0d0e21e 3273 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3274 *fpc++ = FF_LITERAL;
3275 *fpc++ = arg;
3276 }
5f05dabc 3277 postspace = FALSE;
a0d0e21e
LW		 3278 if (s <= send)
3279 skipspaces--;
3280 if (skipspaces) {
3281 *fpc++ = FF_SKIP;
3282 *fpc++ = skipspaces;
3283 }
3284 skipspaces = 0;
3285 if (s <= send)
3286 *fpc++ = FF_NEWLINE;
3287 if (noblank) {
3288 *fpc++ = FF_BLANK;
3289 if (repeat)
3290 arg = fpc - linepc + 1;
3291 else
3292 arg = 0;
3293 *fpc++ = arg;
3294 }
3295 if (s < send) {
3296 linepc = fpc;
3297 *fpc++ = FF_LINEMARK;
3298 noblank = repeat = FALSE;
3299 base = s;
3300 }
3301 else
3302 s++;
3303 continue;
3304
3305 case '@':
3306 case '^':
3307 ischop = s[-1] == '^';
3308
3309 if (postspace) {
3310 *fpc++ = FF_SPACE;
3311 postspace = FALSE;
3312 }
3313 arg = (s - base) - 1;
3314 if (arg) {
3315 *fpc++ = FF_LITERAL;
3316 *fpc++ = arg;
3317 }
3318
3319 base = s - 1;
3320 *fpc++ = FF_FETCH;
3321 if (*s == '*') {
3322 s++;
3323 *fpc++ = 0;
3324 *fpc++ = FF_LINEGLOB;
3325 }
3326 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3327 arg = ischop ? 512 : 0;
3328 base = s - 1;
3329 while (*s == '#')
3330 s++;
3331 if (*s == '.') {
3332 char *f;
3333 s++;
3334 f = s;
3335 while (*s == '#')
3336 s++;
3337 arg |= 256 + (s - f);
3338 }
3339 *fpc++ = s - base; /* fieldsize for FETCH */
3340 *fpc++ = FF_DECIMAL;
3341 *fpc++ = arg;
3342 }
3343 else {
3344 I32 prespace = 0;
3345 bool ismore = FALSE;
3346
3347 if (*s == '>') {
3348 while (*++s == '>') ;
3349 prespace = FF_SPACE;
3350 }
3351 else if (*s == '|') {
3352 while (*++s == '|') ;
3353 prespace = FF_HALFSPACE;
3354 postspace = TRUE;
3355 }
3356 else {
3357 if (*s == '<')
3358 while (*++s == '<') ;
3359 postspace = TRUE;
3360 }
3361 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3362 s += 3;
3363 ismore = TRUE;
3364 }
3365 *fpc++ = s - base; /* fieldsize for FETCH */
3366
3367 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3368
3369 if (prespace)
3370 *fpc++ = prespace;
3371 *fpc++ = FF_ITEM;
3372 if (ismore)
3373 *fpc++ = FF_MORE;
3374 if (ischop)
3375 *fpc++ = FF_CHOP;
3376 }
3377 base = s;
3378 skipspaces = 0;
3379 continue;
3380 }
3381 }
3382 *fpc++ = FF_END;
3383
3384 arg = fpc - fops;
3385 { /* need to jump to the next word */
3386 int z;
3387 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3388 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3389 s = SvPVX(sv) + SvCUR(sv) + z;
3390 }
3391 Copy(fops, s, arg, U16);
3392 Safefree(fops);
55497cff 3393 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3394 SvCOMPILED_on(sv);
3395}
4e35701f 3396
745d3a65
HM		 3397/*
3398 * The rest of this file was derived from source code contributed
3399 * by Tom Horsley.
3400 *
3401 * NOTE: this code was derived from Tom Horsley's qsort replacement
3402 * and should not be confused with the original code.
3403 */
3404
3405/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3406
3407 Permission granted to distribute under the same terms as perl which are
3408 (briefly):
3409
3410 This program is free software; you can redistribute it and/or modify
3411 it under the terms of either:
3412
3413 a) the GNU General Public License as published by the Free
3414 Software Foundation; either version 1, or (at your option) any
3415 later version, or
3416
3417 b) the "Artistic License" which comes with this Kit.
3418
3419 Details on the perl license can be found in the perl source code which
3420 may be located via the www.perl.com web page.
3421
3422 This is the most wonderfulest possible qsort I can come up with (and
3423 still be mostly portable) My (limited) tests indicate it consistently
3424 does about 20% fewer calls to compare than does the qsort in the Visual
3425 C++ library, other vendors may vary.
3426
3427 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3428 others I invented myself (or more likely re-invented since they seemed
3429 pretty obvious once I watched the algorithm operate for a while).
3430
3431 Most of this code was written while watching the Marlins sweep the Giants
3432 in the 1997 National League Playoffs - no Braves fans allowed to use this
3433 code (just kidding :-).
3434
3435 I realize that if I wanted to be true to the perl tradition, the only
3436 comment in this file would be something like:
3437
3438 ...they shuffled back towards the rear of the line. 'No, not at the
3439 rear!' the slave-driver shouted. 'Three files up. And stay there...
3440
3441 However, I really needed to violate that tradition just so I could keep
3442 track of what happens myself, not to mention some poor fool trying to
3443 understand this years from now :-).
3444*/
3445
3446/* ********************************************************** Configuration */
3447
3448#ifndef QSORT_ORDER_GUESS
3449#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3450#endif
3451
3452/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3453 future processing - a good max upper bound is log base 2 of memory size
3454 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3455 safely be smaller than that since the program is taking up some space and
3456 most operating systems only let you grab some subset of contiguous
3457 memory (not to mention that you are normally sorting data larger than
3458 1 byte element size :-).
3459*/
3460#ifndef QSORT_MAX_STACK
3461#define QSORT_MAX_STACK 32
3462#endif
3463
3464/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3465 Anything bigger and we use qsort. If you make this too small, the qsort
3466 will probably break (or become less efficient), because it doesn't expect
3467 the middle element of a partition to be the same as the right or left -
3468 you have been warned).
3469*/
3470#ifndef QSORT_BREAK_EVEN
3471#define QSORT_BREAK_EVEN 6
3472#endif
3473
3474/* ************************************************************* Data Types */
3475
3476/* hold left and right index values of a partition waiting to be sorted (the
3477 partition includes both left and right - right is NOT one past the end or
3478 anything like that).
3479*/
3480struct partition_stack_entry {
3481 int left;
3482 int right;
3483#ifdef QSORT_ORDER_GUESS
3484 int qsort_break_even;
3485#endif
3486};
3487
3488/* ******************************************************* Shorthand Macros */
3489
3490/* Note that these macros will be used from inside the qsort function where
3491 we happen to know that the variable 'elt_size' contains the size of an
3492 array element and the variable 'temp' points to enough space to hold a
3493 temp element and the variable 'array' points to the array being sorted
3494 and 'compare' is the pointer to the compare routine.
3495
3496 Also note that there are very many highly architecture specific ways
3497 these might be sped up, but this is simply the most generally portable
3498 code I could think of.
3499*/
161b471a 3500
745d3a65
HM		 3501/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3502*/
565764a8
DL		 3503#ifdef PERL_OBJECT
3504#define qsort_cmp(elt1, elt2) \
3505 ((this->*compare)(array[elt1], array[elt2]))
3506#else
745d3a65 3507#define qsort_cmp(elt1, elt2) \
864dbfa3 3508 ((*compare)(aTHX_ array[elt1], array[elt2]))
565764a8 3509#endif
745d3a65
HM		 3510
3511#ifdef QSORT_ORDER_GUESS
3512#define QSORT_NOTICE_SWAP swapped++;
3513#else
3514#define QSORT_NOTICE_SWAP
3515#endif
3516
3517/* swaps contents of array elements elt1, elt2.
3518*/
3519#define qsort_swap(elt1, elt2) \
3520 STMT_START { \
3521 QSORT_NOTICE_SWAP \
3522 temp = array[elt1]; \
3523 array[elt1] = array[elt2]; \
3524 array[elt2] = temp; \
3525 } STMT_END
3526
3527/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3528 elt3 and elt3 gets elt1.
3529*/
3530#define qsort_rotate(elt1, elt2, elt3) \
3531 STMT_START { \
3532 QSORT_NOTICE_SWAP \
3533 temp = array[elt1]; \
3534 array[elt1] = array[elt2]; \
3535 array[elt2] = array[elt3]; \
3536 array[elt3] = temp; \
3537 } STMT_END
3538
3539/* ************************************************************ Debug stuff */
3540
3541#ifdef QSORT_DEBUG
3542
3543static void
3544break_here()
3545{
3546 return; /* good place to set a breakpoint */
3547}
3548
3549#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3550
3551static void
3552doqsort_all_asserts(
3553 void * array,
3554 size_t num_elts,
3555 size_t elt_size,
3556 int (*compare)(const void * elt1, const void * elt2),
3557 int pc_left, int pc_right, int u_left, int u_right)
3558{
3559 int i;
3560
3561 qsort_assert(pc_left <= pc_right);
3562 qsort_assert(u_right < pc_left);
3563 qsort_assert(pc_right < u_left);
3564 for (i = u_right + 1; i < pc_left; ++i) {
3565 qsort_assert(qsort_cmp(i, pc_left) < 0);
3566 }
3567 for (i = pc_left; i < pc_right; ++i) {
3568 qsort_assert(qsort_cmp(i, pc_right) == 0);
3569 }
3570 for (i = pc_right + 1; i < u_left; ++i) {
3571 qsort_assert(qsort_cmp(pc_right, i) < 0);
3572 }
3573}
3574
3575#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3576 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3577 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3578
3579#else
3580
3581#define qsort_assert(t) ((void)0)
3582
3583#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3584
3585#endif
3586
3587/* ****************************************************************** qsort */
3588
6cc33c6d 3589STATIC void
cea2e8a9 3590S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
745d3a65
HM		 3591{
3592 register SV * temp;
3593
3594 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3595 int next_stack_entry = 0;
3596
3597 int part_left;
3598 int part_right;
3599#ifdef QSORT_ORDER_GUESS
3600 int qsort_break_even;
3601 int swapped;
3602#endif
161b471a 3603
745d3a65
HM		 3604 /* Make sure we actually have work to do.
3605 */
3606 if (num_elts <= 1) {
3607 return;
3608 }
3609
3610 /* Setup the initial partition definition and fall into the sorting loop
3611 */
3612 part_left = 0;
3613 part_right = (int)(num_elts - 1);
3614#ifdef QSORT_ORDER_GUESS
3615 qsort_break_even = QSORT_BREAK_EVEN;
3616#else
3617#define qsort_break_even QSORT_BREAK_EVEN
3618#endif
3619 for ( ; ; ) {
3620 if ((part_right - part_left) >= qsort_break_even) {
3621 /* OK, this is gonna get hairy, so lets try to document all the
3622 concepts and abbreviations and variables and what they keep
3623 track of:
3624
3625 pc: pivot chunk - the set of array elements we accumulate in the
3626 middle of the partition, all equal in value to the original
3627 pivot element selected. The pc is defined by:
3628
3629 pc_left - the leftmost array index of the pc
3630 pc_right - the rightmost array index of the pc
3631
3632 we start with pc_left == pc_right and only one element
3633 in the pivot chunk (but it can grow during the scan).
3634
3635 u: uncompared elements - the set of elements in the partition
3636 we have not yet compared to the pivot value. There are two
3637 uncompared sets during the scan - one to the left of the pc
3638 and one to the right.
3639
3640 u_right - the rightmost index of the left side's uncompared set
3641 u_left - the leftmost index of the right side's uncompared set
3642
3643 The leftmost index of the left sides's uncompared set
3644 doesn't need its own variable because it is always defined
3645 by the leftmost edge of the whole partition (part_left). The
3646 same goes for the rightmost edge of the right partition
3647 (part_right).
3648
3649 We know there are no uncompared elements on the left once we
3650 get u_right < part_left and no uncompared elements on the
3651 right once u_left > part_right. When both these conditions
3652 are met, we have completed the scan of the partition.
3653
3654 Any elements which are between the pivot chunk and the
3655 uncompared elements should be less than the pivot value on
3656 the left side and greater than the pivot value on the right
3657 side (in fact, the goal of the whole algorithm is to arrange
3658 for that to be true and make the groups of less-than and
3659 greater-then elements into new partitions to sort again).
3660
3661 As you marvel at the complexity of the code and wonder why it
3662 has to be so confusing. Consider some of the things this level
3663 of confusion brings:
3664
3665 Once I do a compare, I squeeze every ounce of juice out of it. I
3666 never do compare calls I don't have to do, and I certainly never
3667 do redundant calls.
3668
3669 I also never swap any elements unless I can prove there is a
3670 good reason. Many sort algorithms will swap a known value with
3671 an uncompared value just to get things in the right place (or
3672 avoid complexity :-), but that uncompared value, once it gets
3673 compared, may then have to be swapped again. A lot of the
3674 complexity of this code is due to the fact that it never swaps
3675 anything except compared values, and it only swaps them when the
3676 compare shows they are out of position.
3677 */
3678 int pc_left, pc_right;
3679 int u_right, u_left;
3680
3681 int s;
3682
3683 pc_left = ((part_left + part_right) / 2);
3684 pc_right = pc_left;
3685 u_right = pc_left - 1;
3686 u_left = pc_right + 1;
3687
3688 /* Qsort works best when the pivot value is also the median value
3689 in the partition (unfortunately you can't find the median value
3690 without first sorting :-), so to give the algorithm a helping
3691 hand, we pick 3 elements and sort them and use the median value
3692 of that tiny set as the pivot value.
3693
3694 Some versions of qsort like to use the left middle and right as
3695 the 3 elements to sort so they can insure the ends of the
3696 partition will contain values which will stop the scan in the
3697 compare loop, but when you have to call an arbitrarily complex
3698 routine to do a compare, its really better to just keep track of
3699 array index values to know when you hit the edge of the
3700 partition and avoid the extra compare. An even better reason to
3701 avoid using a compare call is the fact that you can drop off the
3702 edge of the array if someone foolishly provides you with an
3703 unstable compare function that doesn't always provide consistent
3704 results.
3705
3706 So, since it is simpler for us to compare the three adjacent
3707 elements in the middle of the partition, those are the ones we
3708 pick here (conveniently pointed at by u_right, pc_left, and
3709 u_left). The values of the left, center, and right elements
3710 are refered to as l c and r in the following comments.
3711 */
3712
3713#ifdef QSORT_ORDER_GUESS
3714 swapped = 0;
3715#endif
3716 s = qsort_cmp(u_right, pc_left);
3717 if (s < 0) {
3718 /* l < c */
3719 s = qsort_cmp(pc_left, u_left);
3720 /* if l < c, c < r - already in order - nothing to do */
3721 if (s == 0) {
3722 /* l < c, c == r - already in order, pc grows */
3723 ++pc_right;
3724 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3725 } else if (s > 0) {
3726 /* l < c, c > r - need to know more */
3727 s = qsort_cmp(u_right, u_left);
3728 if (s < 0) {
3729 /* l < c, c > r, l < r - swap c & r to get ordered */
3730 qsort_swap(pc_left, u_left);
3731 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3732 } else if (s == 0) {
3733 /* l < c, c > r, l == r - swap c&r, grow pc */
3734 qsort_swap(pc_left, u_left);
3735 --pc_left;
3736 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3737 } else {
3738 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3739 qsort_rotate(pc_left, u_right, u_left);
3740 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3741 }
3742 }
3743 } else if (s == 0) {
3744 /* l == c */
3745 s = qsort_cmp(pc_left, u_left);
3746 if (s < 0) {
3747 /* l == c, c < r - already in order, grow pc */
3748 --pc_left;
3749 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3750 } else if (s == 0) {
3751 /* l == c, c == r - already in order, grow pc both ways */
3752 --pc_left;
3753 ++pc_right;
3754 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3755 } else {
3756 /* l == c, c > r - swap l & r, grow pc */
3757 qsort_swap(u_right, u_left);
3758 ++pc_right;
3759 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3760 }
3761 } else {
3762 /* l > c */
3763 s = qsort_cmp(pc_left, u_left);
3764 if (s < 0) {
3765 /* l > c, c < r - need to know more */
3766 s = qsort_cmp(u_right, u_left);
3767 if (s < 0) {
3768 /* l > c, c < r, l < r - swap l & c to get ordered */
3769 qsort_swap(u_right, pc_left);
3770 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3771 } else if (s == 0) {
3772 /* l > c, c < r, l == r - swap l & c, grow pc */
3773 qsort_swap(u_right, pc_left);
3774 ++pc_right;
3775 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3776 } else {
3777 /* l > c, c < r, l > r - rotate lcr into crl to order */
3778 qsort_rotate(u_right, pc_left, u_left);
3779 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3780 }
3781 } else if (s == 0) {
3782 /* l > c, c == r - swap ends, grow pc */
3783 qsort_swap(u_right, u_left);
3784 --pc_left;
3785 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3786 } else {
3787 /* l > c, c > r - swap ends to get in order */
3788 qsort_swap(u_right, u_left);
3789 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3790 }
3791 }
3792 /* We now know the 3 middle elements have been compared and
3793 arranged in the desired order, so we can shrink the uncompared
3794 sets on both sides
3795 */
3796 --u_right;
3797 ++u_left;
3798 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3799
3800 /* The above massive nested if was the simple part :-). We now have
3801 the middle 3 elements ordered and we need to scan through the
3802 uncompared sets on either side, swapping elements that are on
3803 the wrong side or simply shuffling equal elements around to get
3804 all equal elements into the pivot chunk.
3805 */
3806
3807 for ( ; ; ) {
3808 int still_work_on_left;
3809 int still_work_on_right;
3810
3811 /* Scan the uncompared values on the left. If I find a value
3812 equal to the pivot value, move it over so it is adjacent to
3813 the pivot chunk and expand the pivot chunk. If I find a value
3814 less than the pivot value, then just leave it - its already
3815 on the correct side of the partition. If I find a greater
3816 value, then stop the scan.
3817 */
3818 while (still_work_on_left = (u_right >= part_left)) {
3819 s = qsort_cmp(u_right, pc_left);
3820 if (s < 0) {
3821 --u_right;
3822 } else if (s == 0) {
3823 --pc_left;
3824 if (pc_left != u_right) {
3825 qsort_swap(u_right, pc_left);
3826 }
3827 --u_right;
3828 } else {
3829 break;
3830 }
3831 qsort_assert(u_right < pc_left);
3832 qsort_assert(pc_left <= pc_right);
3833 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3834 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3835 }
3836
3837 /* Do a mirror image scan of uncompared values on the right
3838 */
3839 while (still_work_on_right = (u_left <= part_right)) {
3840 s = qsort_cmp(pc_right, u_left);
3841 if (s < 0) {
3842 ++u_left;
3843 } else if (s == 0) {
3844 ++pc_right;
3845 if (pc_right != u_left) {
3846 qsort_swap(pc_right, u_left);
3847 }
3848 ++u_left;
3849 } else {
3850 break;
3851 }
3852 qsort_assert(u_left > pc_right);
3853 qsort_assert(pc_left <= pc_right);
3854 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3855 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3856 }
3857
3858 if (still_work_on_left) {
3859 /* I know I have a value on the left side which needs to be
3860 on the right side, but I need to know more to decide
3861 exactly the best thing to do with it.
3862 */
3863 if (still_work_on_right) {
3864 /* I know I have values on both side which are out of
3865 position. This is a big win because I kill two birds
3866 with one swap (so to speak). I can advance the
3867 uncompared pointers on both sides after swapping both
3868 of them into the right place.
3869 */
3870 qsort_swap(u_right, u_left);
3871 --u_right;
3872 ++u_left;
3873 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3874 } else {
3875 /* I have an out of position value on the left, but the
3876 right is fully scanned, so I "slide" the pivot chunk
3877 and any less-than values left one to make room for the
3878 greater value over on the right. If the out of position
3879 value is immediately adjacent to the pivot chunk (there
3880 are no less-than values), I can do that with a swap,
3881 otherwise, I have to rotate one of the less than values
3882 into the former position of the out of position value
3883 and the right end of the pivot chunk into the left end
3884 (got all that?).
3885 */
3886 --pc_left;
3887 if (pc_left == u_right) {
3888 qsort_swap(u_right, pc_right);
3889 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3890 } else {
3891 qsort_rotate(u_right, pc_left, pc_right);
3892 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3893 }
3894 --pc_right;
3895 --u_right;
3896 }
3897 } else if (still_work_on_right) {
3898 /* Mirror image of complex case above: I have an out of
3899 position value on the right, but the left is fully
3900 scanned, so I need to shuffle things around to make room
3901 for the right value on the left.
3902 */
3903 ++pc_right;
3904 if (pc_right == u_left) {
3905 qsort_swap(u_left, pc_left);
3906 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3907 } else {
3908 qsort_rotate(pc_right, pc_left, u_left);
3909 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3910 }
3911 ++pc_left;
3912 ++u_left;
3913 } else {
3914 /* No more scanning required on either side of partition,
3915 break out of loop and figure out next set of partitions
3916 */
3917 break;
3918 }
3919 }
3920
3921 /* The elements in the pivot chunk are now in the right place. They
3922 will never move or be compared again. All I have to do is decide
3923 what to do with the stuff to the left and right of the pivot
3924 chunk.
3925
3926 Notes on the QSORT_ORDER_GUESS ifdef code:
3927
3928 1. If I just built these partitions without swapping any (or
3929 very many) elements, there is a chance that the elements are
3930 already ordered properly (being properly ordered will
3931 certainly result in no swapping, but the converse can't be
3932 proved :-).
3933
3934 2. A (properly written) insertion sort will run faster on
3935 already ordered data than qsort will.
3936
3937 3. Perhaps there is some way to make a good guess about
3938 switching to an insertion sort earlier than partition size 6
3939 (for instance - we could save the partition size on the stack
3940 and increase the size each time we find we didn't swap, thus
3941 switching to insertion sort earlier for partitions with a
3942 history of not swapping).
3943
3944 4. Naturally, if I just switch right away, it will make
3945 artificial benchmarks with pure ascending (or descending)
3946 data look really good, but is that a good reason in general?
3947 Hard to say...
3948 */
3949
3950#ifdef QSORT_ORDER_GUESS
3951 if (swapped < 3) {
3952#if QSORT_ORDER_GUESS == 1
3953 qsort_break_even = (part_right - part_left) + 1;
3954#endif
3955#if QSORT_ORDER_GUESS == 2
3956 qsort_break_even *= 2;
3957#endif
3958#if QSORT_ORDER_GUESS == 3
3959 int prev_break = qsort_break_even;
3960 qsort_break_even *= qsort_break_even;
3961 if (qsort_break_even < prev_break) {
3962 qsort_break_even = (part_right - part_left) + 1;
3963 }
3964#endif
3965 } else {
3966 qsort_break_even = QSORT_BREAK_EVEN;
3967 }
3968#endif
3969
3970 if (part_left < pc_left) {
3971 /* There are elements on the left which need more processing.
3972 Check the right as well before deciding what to do.
3973 */
3974 if (pc_right < part_right) {
3975 /* We have two partitions to be sorted. Stack the biggest one
3976 and process the smallest one on the next iteration. This
3977 minimizes the stack height by insuring that any additional
3978 stack entries must come from the smallest partition which
3979 (because it is smallest) will have the fewest
3980 opportunities to generate additional stack entries.
3981 */
3982 if ((part_right - pc_right) > (pc_left - part_left)) {
3983 /* stack the right partition, process the left */
3984 partition_stack[next_stack_entry].left = pc_right + 1;
3985 partition_stack[next_stack_entry].right = part_right;
3986#ifdef QSORT_ORDER_GUESS
3987 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3988#endif
3989 part_right = pc_left - 1;
3990 } else {
3991 /* stack the left partition, process the right */
3992 partition_stack[next_stack_entry].left = part_left;
3993 partition_stack[next_stack_entry].right = pc_left - 1;
3994#ifdef QSORT_ORDER_GUESS
3995 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3996#endif
3997 part_left = pc_right + 1;
3998 }
3999 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4000 ++next_stack_entry;
4001 } else {
4002 /* The elements on the left are the only remaining elements
4003 that need sorting, arrange for them to be processed as the
4004 next partition.
4005 */
4006 part_right = pc_left - 1;
4007 }
4008 } else if (pc_right < part_right) {
4009 /* There is only one chunk on the right to be sorted, make it
4010 the new partition and loop back around.
4011 */
4012 part_left = pc_right + 1;
4013 } else {
4014 /* This whole partition wound up in the pivot chunk, so
4015 we need to get a new partition off the stack.
4016 */
4017 if (next_stack_entry == 0) {
4018 /* the stack is empty - we are done */
4019 break;
4020 }
4021 --next_stack_entry;
4022 part_left = partition_stack[next_stack_entry].left;
4023 part_right = partition_stack[next_stack_entry].right;
4024#ifdef QSORT_ORDER_GUESS
4025 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4026#endif
4027 }
4028 } else {
4029 /* This partition is too small to fool with qsort complexity, just
4030 do an ordinary insertion sort to minimize overhead.
4031 */
4032 int i;
4033 /* Assume 1st element is in right place already, and start checking
4034 at 2nd element to see where it should be inserted.
4035 */
4036 for (i = part_left + 1; i <= part_right; ++i) {
4037 int j;
4038 /* Scan (backwards - just in case 'i' is already in right place)
4039 through the elements already sorted to see if the ith element
4040 belongs ahead of one of them.
4041 */
4042 for (j = i - 1; j >= part_left; --j) {
4043 if (qsort_cmp(i, j) >= 0) {
4044 /* i belongs right after j
4045 */
4046 break;
4047 }
4048 }
4049 ++j;
4050 if (j != i) {
4051 /* Looks like we really need to move some things
4052 */
b6917549 4053 int k;
745d3a65 4054 temp = array[i];
b6917549
HM		 4055 for (k = i - 1; k >= j; --k)
4056 array[k + 1] = array[k];
745d3a65
HM		 4057 array[j] = temp;
4058 }
4059 }
4060
4061 /* That partition is now sorted, grab the next one, or get out
4062 of the loop if there aren't any more.
4063 */
4064
4065 if (next_stack_entry == 0) {
4066 /* the stack is empty - we are done */
4067 break;
4068 }
4069 --next_stack_entry;
4070 part_left = partition_stack[next_stack_entry].left;
4071 part_right = partition_stack[next_stack_entry].right;
4072#ifdef QSORT_ORDER_GUESS
4073 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4074#endif
4075 }
4076 }
4077
4078 /* Believe it or not, the array is sorted at this point! */
4079}
Unnamed repository; edit this file 'description' to name the repository.