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