This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[win32] fix opendir() problem on share names
[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+1, 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         svp = &GvSV((GV*)POPs);                 /* symbol table variable */
1351         SAVESPTR(*svp);
1352     }
1353
1354     ENTER;
1355
1356     PUSHBLOCK(cx, CXt_LOOP, SP);
1357     PUSHLOOP(cx, svp, MARK);
1358     if (op->op_flags & OPf_STACKED)
1359         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1360     else {
1361         cx->blk_loop.iterary = curstack;
1362         AvFILLp(curstack) = sp - stack_base;
1363         cx->blk_loop.iterix = MARK - stack_base;
1364     }
1365
1366     RETURN;
1367 }
1368
1369 PP(pp_enterloop)
1370 {
1371     djSP;
1372     register PERL_CONTEXT *cx;
1373     I32 gimme = GIMME_V;
1374
1375     ENTER;
1376     SAVETMPS;
1377     ENTER;
1378
1379     PUSHBLOCK(cx, CXt_LOOP, SP);
1380     PUSHLOOP(cx, 0, SP);
1381
1382     RETURN;
1383 }
1384
1385 PP(pp_leaveloop)
1386 {
1387     djSP;
1388     register PERL_CONTEXT *cx;
1389     struct block_loop cxloop;
1390     I32 gimme;
1391     SV **newsp;
1392     PMOP *newpm;
1393     SV **mark;
1394
1395     POPBLOCK(cx,newpm);
1396     mark = newsp;
1397     POPLOOP1(cx);       /* Delay POPLOOP2 until stack values are safe */
1398
1399     TAINT_NOT;
1400     if (gimme == G_VOID)
1401         ; /* do nothing */
1402     else if (gimme == G_SCALAR) {
1403         if (mark < SP)
1404             *++newsp = sv_mortalcopy(*SP);
1405         else
1406             *++newsp = &sv_undef;
1407     }
1408     else {
1409         while (mark < SP) {
1410             *++newsp = sv_mortalcopy(*++mark);
1411             TAINT_NOT;          /* Each item is independent */
1412         }
1413     }
1414     SP = newsp;
1415     PUTBACK;
1416
1417     POPLOOP2();         /* Stack values are safe: release loop vars ... */
1418     curpm = newpm;      /* ... and pop $1 et al */
1419
1420     LEAVE;
1421     LEAVE;
1422
1423     return NORMAL;
1424 }
1425
1426 PP(pp_return)
1427 {
1428     djSP; dMARK;
1429     I32 cxix;
1430     register PERL_CONTEXT *cx;
1431     struct block_sub cxsub;
1432     bool popsub2 = FALSE;
1433     I32 gimme;
1434     SV **newsp;
1435     PMOP *newpm;
1436     I32 optype = 0;
1437
1438     if (curstack == sortstack) {
1439         if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1440             if (cxstack_ix > sortcxix)
1441                 dounwind(sortcxix);
1442             AvARRAY(curstack)[1] = *SP;
1443             stack_sp = stack_base + 1;
1444             return 0;
1445         }
1446     }
1447
1448     cxix = dopoptosub(cxstack_ix);
1449     if (cxix < 0)
1450         DIE("Can't return outside a subroutine");
1451     if (cxix < cxstack_ix)
1452         dounwind(cxix);
1453
1454     POPBLOCK(cx,newpm);
1455     switch (cx->cx_type) {
1456     case CXt_SUB:
1457         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1458         popsub2 = TRUE;
1459         break;
1460     case CXt_EVAL:
1461         POPEVAL(cx);
1462         if (optype == OP_REQUIRE &&
1463             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1464         {
1465             /* Unassume the success we assumed earlier. */
1466             char *name = cx->blk_eval.old_name;
1467             (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1468             DIE("%s did not return a true value", name);
1469         }
1470         break;
1471     default:
1472         DIE("panic: return");
1473     }
1474
1475     TAINT_NOT;
1476     if (gimme == G_SCALAR) {
1477         if (MARK < SP)
1478             *++newsp = (popsub2 && SvTEMP(*SP))
1479                         ? *SP : sv_mortalcopy(*SP);
1480         else
1481             *++newsp = &sv_undef;
1482     }
1483     else if (gimme == G_ARRAY) {
1484         while (++MARK <= SP) {
1485             *++newsp = (popsub2 && SvTEMP(*MARK))
1486                         ? *MARK : sv_mortalcopy(*MARK);
1487             TAINT_NOT;          /* Each item is independent */
1488         }
1489     }
1490     stack_sp = newsp;
1491
1492     /* Stack values are safe: */
1493     if (popsub2) {
1494         POPSUB2();      /* release CV and @_ ... */
1495     }
1496     curpm = newpm;      /* ... and pop $1 et al */
1497
1498     LEAVE;
1499     return pop_return();
1500 }
1501
1502 PP(pp_last)
1503 {
1504     djSP;
1505     I32 cxix;
1506     register PERL_CONTEXT *cx;
1507     struct block_loop cxloop;
1508     struct block_sub cxsub;
1509     I32 pop2 = 0;
1510     I32 gimme;
1511     I32 optype;
1512     OP *nextop;
1513     SV **newsp;
1514     PMOP *newpm;
1515     SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1516
1517     if (op->op_flags & OPf_SPECIAL) {
1518         cxix = dopoptoloop(cxstack_ix);
1519         if (cxix < 0)
1520             DIE("Can't \"last\" outside a block");
1521     }
1522     else {
1523         cxix = dopoptolabel(cPVOP->op_pv);
1524         if (cxix < 0)
1525             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1526     }
1527     if (cxix < cxstack_ix)
1528         dounwind(cxix);
1529
1530     POPBLOCK(cx,newpm);
1531     switch (cx->cx_type) {
1532     case CXt_LOOP:
1533         POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
1534         pop2 = CXt_LOOP;
1535         nextop = cxloop.last_op->op_next;
1536         break;
1537     case CXt_SUB:
1538         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1539         pop2 = CXt_SUB;
1540         nextop = pop_return();
1541         break;
1542     case CXt_EVAL:
1543         POPEVAL(cx);
1544         nextop = pop_return();
1545         break;
1546     default:
1547         DIE("panic: last");
1548     }
1549
1550     TAINT_NOT;
1551     if (gimme == G_SCALAR) {
1552         if (MARK < SP)
1553             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1554                         ? *SP : sv_mortalcopy(*SP);
1555         else
1556             *++newsp = &sv_undef;
1557     }
1558     else if (gimme == G_ARRAY) {
1559         while (++MARK <= SP) {
1560             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1561                         ? *MARK : sv_mortalcopy(*MARK);
1562             TAINT_NOT;          /* Each item is independent */
1563         }
1564     }
1565     SP = newsp;
1566     PUTBACK;
1567
1568     /* Stack values are safe: */
1569     switch (pop2) {
1570     case CXt_LOOP:
1571         POPLOOP2();     /* release loop vars ... */
1572         LEAVE;
1573         break;
1574     case CXt_SUB:
1575         POPSUB2();      /* release CV and @_ ... */
1576         break;
1577     }
1578     curpm = newpm;      /* ... and pop $1 et al */
1579
1580     LEAVE;
1581     return nextop;
1582 }
1583
1584 PP(pp_next)
1585 {
1586     I32 cxix;
1587     register PERL_CONTEXT *cx;
1588     I32 oldsave;
1589
1590     if (op->op_flags & OPf_SPECIAL) {
1591         cxix = dopoptoloop(cxstack_ix);
1592         if (cxix < 0)
1593             DIE("Can't \"next\" outside a block");
1594     }
1595     else {
1596         cxix = dopoptolabel(cPVOP->op_pv);
1597         if (cxix < 0)
1598             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1599     }
1600     if (cxix < cxstack_ix)
1601         dounwind(cxix);
1602
1603     TOPBLOCK(cx);
1604     oldsave = scopestack[scopestack_ix - 1];
1605     LEAVE_SCOPE(oldsave);
1606     return cx->blk_loop.next_op;
1607 }
1608
1609 PP(pp_redo)
1610 {
1611     I32 cxix;
1612     register PERL_CONTEXT *cx;
1613     I32 oldsave;
1614
1615     if (op->op_flags & OPf_SPECIAL) {
1616         cxix = dopoptoloop(cxstack_ix);
1617         if (cxix < 0)
1618             DIE("Can't \"redo\" outside a block");
1619     }
1620     else {
1621         cxix = dopoptolabel(cPVOP->op_pv);
1622         if (cxix < 0)
1623             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1624     }
1625     if (cxix < cxstack_ix)
1626         dounwind(cxix);
1627
1628     TOPBLOCK(cx);
1629     oldsave = scopestack[scopestack_ix - 1];
1630     LEAVE_SCOPE(oldsave);
1631     return cx->blk_loop.redo_op;
1632 }
1633
1634 static OP* lastgotoprobe;
1635
1636 static OP *
1637 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1638 {
1639     OP *kid;
1640     OP **ops = opstack;
1641     static char too_deep[] = "Target of goto is too deeply nested";
1642
1643     if (ops >= oplimit)
1644         croak(too_deep);
1645     if (o->op_type == OP_LEAVE ||
1646         o->op_type == OP_SCOPE ||
1647         o->op_type == OP_LEAVELOOP ||
1648         o->op_type == OP_LEAVETRY)
1649     {
1650         *ops++ = cUNOPo->op_first;
1651         if (ops >= oplimit)
1652             croak(too_deep);
1653     }
1654     *ops = 0;
1655     if (o->op_flags & OPf_KIDS) {
1656         /* First try all the kids at this level, since that's likeliest. */
1657         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1658             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1659                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1660                 return kid;
1661         }
1662         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1663             if (kid == lastgotoprobe)
1664                 continue;
1665             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1666                 (ops == opstack ||
1667                  (ops[-1]->op_type != OP_NEXTSTATE &&
1668                   ops[-1]->op_type != OP_DBSTATE)))
1669                 *ops++ = kid;
1670             if (o = dofindlabel(kid, label, ops, oplimit))
1671                 return o;
1672         }
1673     }
1674     *ops = 0;
1675     return 0;
1676 }
1677
1678 PP(pp_dump)
1679 {
1680     return pp_goto(ARGS);
1681     /*NOTREACHED*/
1682 }
1683
1684 PP(pp_goto)
1685 {
1686     djSP;
1687     OP *retop = 0;
1688     I32 ix;
1689     register PERL_CONTEXT *cx;
1690 #define GOTO_DEPTH 64
1691     OP *enterops[GOTO_DEPTH];
1692     char *label;
1693     int do_dump = (op->op_type == OP_DUMP);
1694
1695     label = 0;
1696     if (op->op_flags & OPf_STACKED) {
1697         SV *sv = POPs;
1698
1699         /* This egregious kludge implements goto &subroutine */
1700         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1701             I32 cxix;
1702             register PERL_CONTEXT *cx;
1703             CV* cv = (CV*)SvRV(sv);
1704             SV** mark;
1705             I32 items = 0;
1706             I32 oldsave;
1707
1708             if (!CvROOT(cv) && !CvXSUB(cv)) {
1709                 if (CvGV(cv)) {
1710                     SV *tmpstr = sv_newmortal();
1711                     gv_efullname3(tmpstr, CvGV(cv), Nullch);
1712                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1713                 }
1714                 DIE("Goto undefined subroutine");
1715             }
1716
1717             /* First do some returnish stuff. */
1718             cxix = dopoptosub(cxstack_ix);
1719             if (cxix < 0)
1720                 DIE("Can't goto subroutine outside a subroutine");
1721             if (cxix < cxstack_ix)
1722                 dounwind(cxix);
1723             TOPBLOCK(cx);
1724             mark = stack_sp;
1725             if (cx->blk_sub.hasargs) {   /* put @_ back onto stack */
1726                 AV* av = cx->blk_sub.argarray;
1727                 
1728                 items = AvFILLp(av) + 1;
1729                 stack_sp++;
1730                 EXTEND(stack_sp, items); /* @_ could have been extended. */
1731                 Copy(AvARRAY(av), stack_sp, items, SV*);
1732                 stack_sp += items;
1733 #ifndef USE_THREADS
1734                 SvREFCNT_dec(GvAV(defgv));
1735                 GvAV(defgv) = cx->blk_sub.savearray;
1736 #endif /* USE_THREADS */
1737                 AvREAL_off(av);
1738                 av_clear(av);
1739             }
1740             if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1741                 SvREFCNT_dec(cx->blk_sub.cv);
1742             oldsave = scopestack[scopestack_ix - 1];
1743             LEAVE_SCOPE(oldsave);
1744
1745             /* Now do some callish stuff. */
1746             SAVETMPS;
1747             if (CvXSUB(cv)) {
1748                 if (CvOLDSTYLE(cv)) {
1749                     I32 (*fp3)_((int,int,int));
1750                     while (sp > mark) {
1751                         sp[1] = sp[0];
1752                         sp--;
1753                     }
1754                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1755                     items = (*fp3)(CvXSUBANY(cv).any_i32,
1756                                    mark - stack_base + 1,
1757                                    items);
1758                     sp = stack_base + items;
1759                 }
1760                 else {
1761                     stack_sp--;         /* There is no cv arg. */
1762                     (void)(*CvXSUB(cv))(cv);
1763                 }
1764                 LEAVE;
1765                 return pop_return();
1766             }
1767             else {
1768                 AV* padlist = CvPADLIST(cv);
1769                 SV** svp = AvARRAY(padlist);
1770                 cx->blk_sub.cv = cv;
1771                 cx->blk_sub.olddepth = CvDEPTH(cv);
1772                 CvDEPTH(cv)++;
1773                 if (CvDEPTH(cv) < 2)
1774                     (void)SvREFCNT_inc(cv);
1775                 else {  /* save temporaries on recursion? */
1776                     if (CvDEPTH(cv) == 100 && dowarn)
1777                         sub_crush_depth(cv);
1778                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
1779                         AV *newpad = newAV();
1780                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1781                         I32 ix = AvFILLp((AV*)svp[1]);
1782                         svp = AvARRAY(svp[0]);
1783                         for ( ;ix > 0; ix--) {
1784                             if (svp[ix] != &sv_undef) {
1785                                 char *name = SvPVX(svp[ix]);
1786                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1787                                     || *name == '&')
1788                                 {
1789                                     /* outer lexical or anon code */
1790                                     av_store(newpad, ix,
1791                                         SvREFCNT_inc(oldpad[ix]) );
1792                                 }
1793                                 else {          /* our own lexical */
1794                                     if (*name == '@')
1795                                         av_store(newpad, ix, sv = (SV*)newAV());
1796                                     else if (*name == '%')
1797                                         av_store(newpad, ix, sv = (SV*)newHV());
1798                                     else
1799                                         av_store(newpad, ix, sv = NEWSV(0,0));
1800                                     SvPADMY_on(sv);
1801                                 }
1802                             }
1803                             else {
1804                                 av_store(newpad, ix, sv = NEWSV(0,0));
1805                                 SvPADTMP_on(sv);
1806                             }
1807                         }
1808                         if (cx->blk_sub.hasargs) {
1809                             AV* av = newAV();
1810                             av_extend(av, 0);
1811                             av_store(newpad, 0, (SV*)av);
1812                             AvFLAGS(av) = AVf_REIFY;
1813                         }
1814                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1815                         AvFILLp(padlist) = CvDEPTH(cv);
1816                         svp = AvARRAY(padlist);
1817                     }
1818                 }
1819 #ifdef USE_THREADS
1820                 if (!cx->blk_sub.hasargs) {
1821                     AV* av = (AV*)curpad[0];
1822                     
1823                     items = AvFILLp(av) + 1;
1824                     if (items) {
1825                         /* Mark is at the end of the stack. */
1826                         EXTEND(sp, items);
1827                         Copy(AvARRAY(av), sp + 1, items, SV*);
1828                         sp += items;
1829                         PUTBACK ;                   
1830                     }
1831                 }
1832 #endif /* USE_THREADS */                
1833                 SAVESPTR(curpad);
1834                 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1835 #ifndef USE_THREADS
1836                 if (cx->blk_sub.hasargs)
1837 #endif /* USE_THREADS */
1838                 {
1839                     AV* av = (AV*)curpad[0];
1840                     SV** ary;
1841
1842 #ifndef USE_THREADS
1843                     cx->blk_sub.savearray = GvAV(defgv);
1844                     GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1845 #endif /* USE_THREADS */
1846                     cx->blk_sub.argarray = av;
1847                     ++mark;
1848
1849                     if (items >= AvMAX(av) + 1) {
1850                         ary = AvALLOC(av);
1851                         if (AvARRAY(av) != ary) {
1852                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1853                             SvPVX(av) = (char*)ary;
1854                         }
1855                         if (items >= AvMAX(av) + 1) {
1856                             AvMAX(av) = items - 1;
1857                             Renew(ary,items+1,SV*);
1858                             AvALLOC(av) = ary;
1859                             SvPVX(av) = (char*)ary;
1860                         }
1861                     }
1862                     Copy(mark,AvARRAY(av),items,SV*);
1863                     AvFILLp(av) = items - 1;
1864                     
1865                     while (items--) {
1866                         if (*mark)
1867                             SvTEMP_off(*mark);
1868                         mark++;
1869                     }
1870                 }
1871                 if (PERLDB_SUB && curstash != debstash) {
1872                     /*
1873                      * We do not care about using sv to call CV;
1874                      * it's for informational purposes only.
1875                      */
1876                     SV *sv = GvSV(DBsub);
1877                     save_item(sv);
1878                     gv_efullname3(sv, CvGV(cv), Nullch);
1879                 }
1880                 RETURNOP(CvSTART(cv));
1881             }
1882         }
1883         else
1884             label = SvPV(sv,na);
1885     }
1886     else if (op->op_flags & OPf_SPECIAL) {
1887         if (! do_dump)
1888             DIE("goto must have label");
1889     }
1890     else
1891         label = cPVOP->op_pv;
1892
1893     if (label && *label) {
1894         OP *gotoprobe = 0;
1895
1896         /* find label */
1897
1898         lastgotoprobe = 0;
1899         *enterops = 0;
1900         for (ix = cxstack_ix; ix >= 0; ix--) {
1901             cx = &cxstack[ix];
1902             switch (cx->cx_type) {
1903             case CXt_EVAL:
1904                 gotoprobe = eval_root; /* XXX not good for nested eval */
1905                 break;
1906             case CXt_LOOP:
1907                 gotoprobe = cx->blk_oldcop->op_sibling;
1908                 break;
1909             case CXt_SUBST:
1910                 continue;
1911             case CXt_BLOCK:
1912                 if (ix)
1913                     gotoprobe = cx->blk_oldcop->op_sibling;
1914                 else
1915                     gotoprobe = main_root;
1916                 break;
1917             case CXt_SUB:
1918                 if (CvDEPTH(cx->blk_sub.cv)) {
1919                     gotoprobe = CvROOT(cx->blk_sub.cv);
1920                     break;
1921                 }
1922                 /* FALL THROUGH */
1923             case CXt_NULL:
1924                 DIE("Can't \"goto\" outside a block");
1925             default:
1926                 if (ix)
1927                     DIE("panic: goto");
1928                 gotoprobe = main_root;
1929                 break;
1930             }
1931             retop = dofindlabel(gotoprobe, label,
1932                                 enterops, enterops + GOTO_DEPTH);
1933             if (retop)
1934                 break;
1935             lastgotoprobe = gotoprobe;
1936         }
1937         if (!retop)
1938             DIE("Can't find label %s", label);
1939
1940         /* pop unwanted frames */
1941
1942         if (ix < cxstack_ix) {
1943             I32 oldsave;
1944
1945             if (ix < 0)
1946                 ix = 0;
1947             dounwind(ix);
1948             TOPBLOCK(cx);
1949             oldsave = scopestack[scopestack_ix];
1950             LEAVE_SCOPE(oldsave);
1951         }
1952
1953         /* push wanted frames */
1954
1955         if (*enterops && enterops[1]) {
1956             OP *oldop = op;
1957             for (ix = 1; enterops[ix]; ix++) {
1958                 op = enterops[ix];
1959                 /* Eventually we may want to stack the needed arguments
1960                  * for each op.  For now, we punt on the hard ones. */
1961                 if (op->op_type == OP_ENTERITER)
1962                     DIE("Can't \"goto\" into the middle of a foreach loop",
1963                         label);
1964                 (*op->op_ppaddr)(ARGS);
1965             }
1966             op = oldop;
1967         }
1968     }
1969
1970     if (do_dump) {
1971 #ifdef VMS
1972         if (!retop) retop = main_start;
1973 #endif
1974         restartop = retop;
1975         do_undump = TRUE;
1976
1977         my_unexec();
1978
1979         restartop = 0;          /* hmm, must be GNU unexec().. */
1980         do_undump = FALSE;
1981     }
1982
1983     if (curstack == signalstack) {
1984         restartop = retop;
1985         JMPENV_JUMP(3);
1986     }
1987
1988     RETURNOP(retop);
1989 }
1990
1991 PP(pp_exit)
1992 {
1993     djSP;
1994     I32 anum;
1995
1996     if (MAXARG < 1)
1997         anum = 0;
1998     else {
1999         anum = SvIVx(POPs);
2000 #ifdef VMSISH_EXIT
2001         if (anum == 1 && VMSISH_EXIT)
2002             anum = 0;
2003 #endif
2004     }
2005     my_exit(anum);
2006     PUSHs(&sv_undef);
2007     RETURN;
2008 }
2009
2010 #ifdef NOTYET
2011 PP(pp_nswitch)
2012 {
2013     djSP;
2014     double value = SvNVx(GvSV(cCOP->cop_gv));
2015     register I32 match = I_32(value);
2016
2017     if (value < 0.0) {
2018         if (((double)match) > value)
2019             --match;            /* was fractional--truncate other way */
2020     }
2021     match -= cCOP->uop.scop.scop_offset;
2022     if (match < 0)
2023         match = 0;
2024     else if (match > cCOP->uop.scop.scop_max)
2025         match = cCOP->uop.scop.scop_max;
2026     op = cCOP->uop.scop.scop_next[match];
2027     RETURNOP(op);
2028 }
2029
2030 PP(pp_cswitch)
2031 {
2032     djSP;
2033     register I32 match;
2034
2035     if (multiline)
2036         op = op->op_next;                       /* can't assume anything */
2037     else {
2038         match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2039         match -= cCOP->uop.scop.scop_offset;
2040         if (match < 0)
2041             match = 0;
2042         else if (match > cCOP->uop.scop.scop_max)
2043             match = cCOP->uop.scop.scop_max;
2044         op = cCOP->uop.scop.scop_next[match];
2045     }
2046     RETURNOP(op);
2047 }
2048 #endif
2049
2050 /* Eval. */
2051
2052 static void
2053 save_lines(AV *array, SV *sv)
2054 {
2055     register char *s = SvPVX(sv);
2056     register char *send = SvPVX(sv) + SvCUR(sv);
2057     register char *t;
2058     register I32 line = 1;
2059
2060     while (s && s < send) {
2061         SV *tmpstr = NEWSV(85,0);
2062
2063         sv_upgrade(tmpstr, SVt_PVMG);
2064         t = strchr(s, '\n');
2065         if (t)
2066             t++;
2067         else
2068             t = send;
2069
2070         sv_setpvn(tmpstr, s, t - s);
2071         av_store(array, line++, tmpstr);
2072         s = t;
2073     }
2074 }
2075
2076 static OP *
2077 docatch(OP *o)
2078 {
2079     dTHR;
2080     int ret;
2081     OP *oldop = op;
2082     dJMPENV;
2083
2084     op = o;
2085 #ifdef DEBUGGING
2086     assert(CATCH_GET == TRUE);
2087     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2088 #endif
2089     JMPENV_PUSH(ret);
2090     switch (ret) {
2091     default:                            /* topmost level handles it */
2092         JMPENV_POP;
2093         op = oldop;
2094         JMPENV_JUMP(ret);
2095         /* NOTREACHED */
2096     case 3:
2097         if (!restartop) {
2098             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2099             break;
2100         }
2101         op = restartop;
2102         restartop = 0;
2103         /* FALL THROUGH */
2104     case 0:
2105         runops();
2106         break;
2107     }
2108     JMPENV_POP;
2109     op = oldop;
2110     return Nullop;
2111 }
2112
2113 OP *
2114 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2115 /* sv Text to convert to OP tree. */
2116 /* startop op_free() this to undo. */
2117 /* code Short string id of the caller. */
2118 {
2119     dSP;                                /* Make POPBLOCK work. */
2120     PERL_CONTEXT *cx;
2121     SV **newsp;
2122     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2123     I32 optype;
2124     OP dummy;
2125     OP *oop = op, *rop;
2126     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2127     char *safestr;
2128
2129     ENTER;
2130     lex_start(sv);
2131     SAVETMPS;
2132     /* switch to eval mode */
2133
2134     SAVESPTR(compiling.cop_filegv);
2135     SAVEI16(compiling.cop_line);
2136     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2137     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2138     compiling.cop_line = 1;
2139     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2140        deleting the eval's FILEGV from the stash before gv_check() runs
2141        (i.e. before run-time proper). To work around the coredump that
2142        ensues, we always turn GvMULTI_on for any globals that were
2143        introduced within evals. See force_ident(). GSAR 96-10-12 */
2144     safestr = savepv(tmpbuf);
2145     SAVEDELETE(defstash, safestr, strlen(safestr));
2146     SAVEI32(hints);
2147     SAVEPPTR(op);
2148     hints = 0;
2149
2150     op = &dummy;
2151     op->op_type = 0;                    /* Avoid uninit warning. */
2152     op->op_flags = 0;                   /* Avoid uninit warning. */
2153     PUSHBLOCK(cx, CXt_EVAL, SP);
2154     PUSHEVAL(cx, 0, compiling.cop_filegv);
2155     rop = doeval(G_SCALAR, startop);
2156     POPBLOCK(cx,curpm);
2157     POPEVAL(cx);
2158
2159     (*startop)->op_type = OP_NULL;
2160     (*startop)->op_ppaddr = ppaddr[OP_NULL];
2161     lex_end();
2162     *avp = (AV*)SvREFCNT_inc(comppad);
2163     LEAVE;
2164     return rop;
2165 }
2166
2167 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2168 static OP *
2169 doeval(int gimme, OP** startop)
2170 {
2171     dSP;
2172     OP *saveop = op;
2173     HV *newstash;
2174     CV *caller;
2175     AV* comppadlist;
2176     I32 i;
2177
2178     in_eval = 1;
2179
2180     PUSHMARK(SP);
2181
2182     /* set up a scratch pad */
2183
2184     SAVEI32(padix);
2185     SAVESPTR(curpad);
2186     SAVESPTR(comppad);
2187     SAVESPTR(comppad_name);
2188     SAVEI32(comppad_name_fill);
2189     SAVEI32(min_intro_pending);
2190     SAVEI32(max_intro_pending);
2191
2192     caller = compcv;
2193     for (i = cxstack_ix - 1; i >= 0; i--) {
2194         PERL_CONTEXT *cx = &cxstack[i];
2195         if (cx->cx_type == CXt_EVAL)
2196             break;
2197         else if (cx->cx_type == CXt_SUB) {
2198             caller = cx->blk_sub.cv;
2199             break;
2200         }
2201     }
2202
2203     SAVESPTR(compcv);
2204     compcv = (CV*)NEWSV(1104,0);
2205     sv_upgrade((SV *)compcv, SVt_PVCV);
2206     CvUNIQUE_on(compcv);
2207 #ifdef USE_THREADS
2208     CvOWNER(compcv) = 0;
2209     New(666, CvMUTEXP(compcv), 1, perl_mutex);
2210     MUTEX_INIT(CvMUTEXP(compcv));
2211 #endif /* USE_THREADS */
2212
2213     comppad = newAV();
2214     av_push(comppad, Nullsv);
2215     curpad = AvARRAY(comppad);
2216     comppad_name = newAV();
2217     comppad_name_fill = 0;
2218     min_intro_pending = 0;
2219     padix = 0;
2220 #ifdef USE_THREADS
2221     av_store(comppad_name, 0, newSVpv("@_", 2));
2222     curpad[0] = (SV*)newAV();
2223     SvPADMY_on(curpad[0]);      /* XXX Needed? */
2224 #endif /* USE_THREADS */
2225
2226     comppadlist = newAV();
2227     AvREAL_off(comppadlist);
2228     av_store(comppadlist, 0, (SV*)comppad_name);
2229     av_store(comppadlist, 1, (SV*)comppad);
2230     CvPADLIST(compcv) = comppadlist;
2231
2232     if (!saveop || saveop->op_type != OP_REQUIRE)
2233         CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2234
2235     SAVEFREESV(compcv);
2236
2237     /* make sure we compile in the right package */
2238
2239     newstash = curcop->cop_stash;
2240     if (curstash != newstash) {
2241         SAVESPTR(curstash);
2242         curstash = newstash;
2243     }
2244     SAVESPTR(beginav);
2245     beginav = newAV();
2246     SAVEFREESV(beginav);
2247
2248     /* try to compile it */
2249
2250     eval_root = Nullop;
2251     error_count = 0;
2252     curcop = &compiling;
2253     curcop->cop_arybase = 0;
2254     SvREFCNT_dec(rs);
2255     rs = newSVpv("\n", 1);
2256     if (saveop && saveop->op_flags & OPf_SPECIAL)
2257         in_eval |= 4;
2258     else
2259         sv_setpv(ERRSV,"");
2260     if (yyparse() || error_count || !eval_root) {
2261         SV **newsp;
2262         I32 gimme;
2263         PERL_CONTEXT *cx;
2264         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2265
2266         op = saveop;
2267         if (eval_root) {
2268             op_free(eval_root);
2269             eval_root = Nullop;
2270         }
2271         SP = stack_base + POPMARK;              /* pop original mark */
2272         if (!startop) {
2273             POPBLOCK(cx,curpm);
2274             POPEVAL(cx);
2275             pop_return();
2276         }
2277         lex_end();
2278         LEAVE;
2279         if (optype == OP_REQUIRE) {
2280             char* msg = SvPVx(ERRSV, na);
2281             DIE("%s", *msg ? msg : "Compilation failed in require");
2282         } else if (startop) {
2283             char* msg = SvPVx(ERRSV, na);
2284
2285             POPBLOCK(cx,curpm);
2286             POPEVAL(cx);
2287             croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2288         }
2289         SvREFCNT_dec(rs);
2290         rs = SvREFCNT_inc(nrs);
2291 #ifdef USE_THREADS
2292         MUTEX_LOCK(&eval_mutex);
2293         eval_owner = 0;
2294         COND_SIGNAL(&eval_cond);
2295         MUTEX_UNLOCK(&eval_mutex);
2296 #endif /* USE_THREADS */
2297         RETPUSHUNDEF;
2298     }
2299     SvREFCNT_dec(rs);
2300     rs = SvREFCNT_inc(nrs);
2301     compiling.cop_line = 0;
2302     if (startop) {
2303         *startop = eval_root;
2304         SvREFCNT_dec(CvOUTSIDE(compcv));
2305         CvOUTSIDE(compcv) = Nullcv;
2306     } else
2307         SAVEFREEOP(eval_root);
2308     if (gimme & G_VOID)
2309         scalarvoid(eval_root);
2310     else if (gimme & G_ARRAY)
2311         list(eval_root);
2312     else
2313         scalar(eval_root);
2314
2315     DEBUG_x(dump_eval());
2316
2317     /* Register with debugger: */
2318     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2319         CV *cv = perl_get_cv("DB::postponed", FALSE);
2320         if (cv) {
2321             dSP;
2322             PUSHMARK(sp);
2323             XPUSHs((SV*)compiling.cop_filegv);
2324             PUTBACK;
2325             perl_call_sv((SV*)cv, G_DISCARD);
2326         }
2327     }
2328
2329     /* compiled okay, so do it */
2330
2331     CvDEPTH(compcv) = 1;
2332     SP = stack_base + POPMARK;          /* pop original mark */
2333     op = saveop;                        /* The caller may need it. */
2334 #ifdef USE_THREADS
2335     MUTEX_LOCK(&eval_mutex);
2336     eval_owner = 0;
2337     COND_SIGNAL(&eval_cond);
2338     MUTEX_UNLOCK(&eval_mutex);
2339 #endif /* USE_THREADS */
2340
2341     RETURNOP(eval_start);
2342 }
2343
2344 PP(pp_require)
2345 {
2346     djSP;
2347     register PERL_CONTEXT *cx;
2348     SV *sv;
2349     char *name;
2350     char *tryname;
2351     SV *namesv = Nullsv;
2352     SV** svp;
2353     I32 gimme = G_SCALAR;
2354     PerlIO *tryrsfp = 0;
2355
2356     sv = POPs;
2357     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2358         SET_NUMERIC_STANDARD();
2359         if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2360             DIE("Perl %s required--this is only version %s, stopped",
2361                 SvPV(sv,na),patchlevel);
2362         RETPUSHYES;
2363     }
2364     name = SvPV(sv, na);
2365     if (!*name)
2366         DIE("Null filename used");
2367     TAINT_PROPER("require");
2368     if (op->op_type == OP_REQUIRE &&
2369       (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
2370       *svp != &sv_undef)
2371         RETPUSHYES;
2372
2373     /* prepare to compile file */
2374
2375     if (*name == '/' ||
2376         (*name == '.' && 
2377             (name[1] == '/' ||
2378              (name[1] == '.' && name[2] == '/')))
2379 #ifdef DOSISH
2380       || (name[0] && name[1] == ':')
2381 #endif
2382 #ifdef WIN32
2383       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2384 #endif
2385 #ifdef VMS
2386         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2387             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2388 #endif
2389     )
2390     {
2391         tryname = name;
2392         tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2393     }
2394     else {
2395         AV *ar = GvAVn(incgv);
2396         I32 i;
2397 #ifdef VMS
2398         char *unixname;
2399         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2400 #endif
2401         {
2402             namesv = NEWSV(806, 0);
2403             for (i = 0; i <= AvFILL(ar); i++) {
2404                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2405 #ifdef VMS
2406                 char *unixdir;
2407                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2408                     continue;
2409                 sv_setpv(namesv, unixdir);
2410                 sv_catpv(namesv, unixname);
2411 #else
2412                 sv_setpvf(namesv, "%s/%s", dir, name);
2413 #endif
2414                 tryname = SvPVX(namesv);
2415                 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2416                 if (tryrsfp) {
2417                     if (tryname[0] == '.' && tryname[1] == '/')
2418                         tryname += 2;
2419                     break;
2420                 }
2421             }
2422         }
2423     }
2424     SAVESPTR(compiling.cop_filegv);
2425     compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2426     SvREFCNT_dec(namesv);
2427     if (!tryrsfp) {
2428         if (op->op_type == OP_REQUIRE) {
2429             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2430             SV *dirmsgsv = NEWSV(0, 0);
2431             AV *ar = GvAVn(incgv);
2432             I32 i;
2433             if (instr(SvPVX(msg), ".h "))
2434                 sv_catpv(msg, " (change .h to .ph maybe?)");
2435             if (instr(SvPVX(msg), ".ph "))
2436                 sv_catpv(msg, " (did you run h2ph?)");
2437             sv_catpv(msg, " (@INC contains:");
2438             for (i = 0; i <= AvFILL(ar); i++) {
2439                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2440                 sv_setpvf(dirmsgsv, " %s", dir);
2441                 sv_catsv(msg, dirmsgsv);
2442             }
2443             sv_catpvn(msg, ")", 1);
2444             SvREFCNT_dec(dirmsgsv);
2445             DIE("%_", msg);
2446         }
2447
2448         RETPUSHUNDEF;
2449     }
2450
2451     /* Assume success here to prevent recursive requirement. */
2452     (void)hv_store(GvHVn(incgv), name, strlen(name),
2453         newSVsv(GvSV(compiling.cop_filegv)), 0 );
2454
2455     ENTER;
2456     SAVETMPS;
2457     lex_start(sv_2mortal(newSVpv("",0)));
2458     if (rsfp_filters){
2459         save_aptr(&rsfp_filters);
2460         rsfp_filters = NULL;
2461     }
2462
2463     rsfp = tryrsfp;
2464     name = savepv(name);
2465     SAVEFREEPV(name);
2466     SAVEI32(hints);
2467     hints = 0;
2468  
2469     /* switch to eval mode */
2470
2471     push_return(op->op_next);
2472     PUSHBLOCK(cx, CXt_EVAL, SP);
2473     PUSHEVAL(cx, name, compiling.cop_filegv);
2474
2475     compiling.cop_line = 0;
2476
2477     PUTBACK;
2478 #ifdef USE_THREADS
2479     MUTEX_LOCK(&eval_mutex);
2480     if (eval_owner && eval_owner != thr)
2481         while (eval_owner)
2482             COND_WAIT(&eval_cond, &eval_mutex);
2483     eval_owner = thr;
2484     MUTEX_UNLOCK(&eval_mutex);
2485 #endif /* USE_THREADS */
2486     return DOCATCH(doeval(G_SCALAR, NULL));
2487 }
2488
2489 PP(pp_dofile)
2490 {
2491     return pp_require(ARGS);
2492 }
2493
2494 PP(pp_entereval)
2495 {
2496     djSP;
2497     register PERL_CONTEXT *cx;
2498     dPOPss;
2499     I32 gimme = GIMME_V, was = sub_generation;
2500     char tmpbuf[TYPE_DIGITS(long) + 12];
2501     char *safestr;
2502     STRLEN len;
2503     OP *ret;
2504
2505     if (!SvPV(sv,len) || !len)
2506         RETPUSHUNDEF;
2507     TAINT_PROPER("eval");
2508
2509     ENTER;
2510     lex_start(sv);
2511     SAVETMPS;
2512  
2513     /* switch to eval mode */
2514
2515     SAVESPTR(compiling.cop_filegv);
2516     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2517     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2518     compiling.cop_line = 1;
2519     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2520        deleting the eval's FILEGV from the stash before gv_check() runs
2521        (i.e. before run-time proper). To work around the coredump that
2522        ensues, we always turn GvMULTI_on for any globals that were
2523        introduced within evals. See force_ident(). GSAR 96-10-12 */
2524     safestr = savepv(tmpbuf);
2525     SAVEDELETE(defstash, safestr, strlen(safestr));
2526     SAVEI32(hints);
2527     hints = op->op_targ;
2528
2529     push_return(op->op_next);
2530     PUSHBLOCK(cx, CXt_EVAL, SP);
2531     PUSHEVAL(cx, 0, compiling.cop_filegv);
2532
2533     /* prepare to compile string */
2534
2535     if (PERLDB_LINE && curstash != debstash)
2536         save_lines(GvAV(compiling.cop_filegv), linestr);
2537     PUTBACK;
2538 #ifdef USE_THREADS
2539     MUTEX_LOCK(&eval_mutex);
2540     if (eval_owner && eval_owner != thr)
2541         while (eval_owner)
2542             COND_WAIT(&eval_cond, &eval_mutex);
2543     eval_owner = thr;
2544     MUTEX_UNLOCK(&eval_mutex);
2545 #endif /* USE_THREADS */
2546     ret = doeval(gimme, NULL);
2547     if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2548         && ret != op->op_next) {        /* Successive compilation. */
2549         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2550     }
2551     return DOCATCH(ret);
2552 }
2553
2554 PP(pp_leaveeval)
2555 {
2556     djSP;
2557     register SV **mark;
2558     SV **newsp;
2559     PMOP *newpm;
2560     I32 gimme;
2561     register PERL_CONTEXT *cx;
2562     OP *retop;
2563     U8 save_flags = op -> op_flags;
2564     I32 optype;
2565
2566     POPBLOCK(cx,newpm);
2567     POPEVAL(cx);
2568     retop = pop_return();
2569
2570     TAINT_NOT;
2571     if (gimme == G_VOID)
2572         MARK = newsp;
2573     else if (gimme == G_SCALAR) {
2574         MARK = newsp + 1;
2575         if (MARK <= SP) {
2576             if (SvFLAGS(TOPs) & SVs_TEMP)
2577                 *MARK = TOPs;
2578             else
2579                 *MARK = sv_mortalcopy(TOPs);
2580         }
2581         else {
2582             MEXTEND(mark,0);
2583             *MARK = &sv_undef;
2584         }
2585     }
2586     else {
2587         /* in case LEAVE wipes old return values */
2588         for (mark = newsp + 1; mark <= SP; mark++) {
2589             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2590                 *mark = sv_mortalcopy(*mark);
2591                 TAINT_NOT;      /* Each item is independent */
2592             }
2593         }
2594     }
2595     curpm = newpm;      /* Don't pop $1 et al till now */
2596
2597     /*
2598      * Closures mentioned at top level of eval cannot be referenced
2599      * again, and their presence indirectly causes a memory leak.
2600      * (Note that the fact that compcv and friends are still set here
2601      * is, AFAIK, an accident.)  --Chip
2602      */
2603     if (AvFILLp(comppad_name) >= 0) {
2604         SV **svp = AvARRAY(comppad_name);
2605         I32 ix;
2606         for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2607             SV *sv = svp[ix];
2608             if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2609                 SvREFCNT_dec(sv);
2610                 svp[ix] = &sv_undef;
2611
2612                 sv = curpad[ix];
2613                 if (CvCLONE(sv)) {
2614                     SvREFCNT_dec(CvOUTSIDE(sv));
2615                     CvOUTSIDE(sv) = Nullcv;
2616                 }
2617                 else {
2618                     SvREFCNT_dec(sv);
2619                     sv = NEWSV(0,0);
2620                     SvPADTMP_on(sv);
2621                     curpad[ix] = sv;
2622                 }
2623             }
2624         }
2625     }
2626
2627 #ifdef DEBUGGING
2628     assert(CvDEPTH(compcv) == 1);
2629 #endif
2630     CvDEPTH(compcv) = 0;
2631
2632     if (optype == OP_REQUIRE &&
2633         !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp))
2634     {
2635         /* Unassume the success we assumed earlier. */
2636         char *name = cx->blk_eval.old_name;
2637         (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2638         retop = die("%s did not return a true value", name);
2639     }
2640
2641     lex_end();
2642     LEAVE;
2643
2644     if (!(save_flags & OPf_SPECIAL))
2645         sv_setpv(ERRSV,"");
2646
2647     RETURNOP(retop);
2648 }
2649
2650 PP(pp_entertry)
2651 {
2652     djSP;
2653     register PERL_CONTEXT *cx;
2654     I32 gimme = GIMME_V;
2655
2656     ENTER;
2657     SAVETMPS;
2658
2659     push_return(cLOGOP->op_other->op_next);
2660     PUSHBLOCK(cx, CXt_EVAL, SP);
2661     PUSHEVAL(cx, 0, 0);
2662     eval_root = op;             /* Only needed so that goto works right. */
2663
2664     in_eval = 1;
2665     sv_setpv(ERRSV,"");
2666     PUTBACK;
2667     return DOCATCH(op->op_next);
2668 }
2669
2670 PP(pp_leavetry)
2671 {
2672     djSP;
2673     register SV **mark;
2674     SV **newsp;
2675     PMOP *newpm;
2676     I32 gimme;
2677     register PERL_CONTEXT *cx;
2678     I32 optype;
2679
2680     POPBLOCK(cx,newpm);
2681     POPEVAL(cx);
2682     pop_return();
2683
2684     TAINT_NOT;
2685     if (gimme == G_VOID)
2686         SP = newsp;
2687     else if (gimme == G_SCALAR) {
2688         MARK = newsp + 1;
2689         if (MARK <= SP) {
2690             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2691                 *MARK = TOPs;
2692             else
2693                 *MARK = sv_mortalcopy(TOPs);
2694         }
2695         else {
2696             MEXTEND(mark,0);
2697             *MARK = &sv_undef;
2698         }
2699         SP = MARK;
2700     }
2701     else {
2702         /* in case LEAVE wipes old return values */
2703         for (mark = newsp + 1; mark <= SP; mark++) {
2704             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2705                 *mark = sv_mortalcopy(*mark);
2706                 TAINT_NOT;      /* Each item is independent */
2707             }
2708         }
2709     }
2710     curpm = newpm;      /* Don't pop $1 et al till now */
2711
2712     LEAVE;
2713     sv_setpv(ERRSV,"");
2714     RETURN;
2715 }
2716
2717 static void
2718 doparseform(SV *sv)
2719 {
2720     STRLEN len;
2721     register char *s = SvPV_force(sv, len);
2722     register char *send = s + len;
2723     register char *base;
2724     register I32 skipspaces = 0;
2725     bool noblank;
2726     bool repeat;
2727     bool postspace = FALSE;
2728     U16 *fops;
2729     register U16 *fpc;
2730     U16 *linepc;
2731     register I32 arg;
2732     bool ischop;
2733
2734     if (len == 0)
2735         croak("Null picture in formline");
2736     
2737     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
2738     fpc = fops;
2739
2740     if (s < send) {
2741         linepc = fpc;
2742         *fpc++ = FF_LINEMARK;
2743         noblank = repeat = FALSE;
2744         base = s;
2745     }
2746
2747     while (s <= send) {
2748         switch (*s++) {
2749         default:
2750             skipspaces = 0;
2751             continue;
2752
2753         case '~':
2754             if (*s == '~') {
2755                 repeat = TRUE;
2756                 *s = ' ';
2757             }
2758             noblank = TRUE;
2759             s[-1] = ' ';
2760             /* FALL THROUGH */
2761         case ' ': case '\t':
2762             skipspaces++;
2763             continue;
2764             
2765         case '\n': case 0:
2766             arg = s - base;
2767             skipspaces++;
2768             arg -= skipspaces;
2769             if (arg) {
2770                 if (postspace)
2771                     *fpc++ = FF_SPACE;
2772                 *fpc++ = FF_LITERAL;
2773                 *fpc++ = arg;
2774             }
2775             postspace = FALSE;
2776             if (s <= send)
2777                 skipspaces--;
2778             if (skipspaces) {
2779                 *fpc++ = FF_SKIP;
2780                 *fpc++ = skipspaces;
2781             }
2782             skipspaces = 0;
2783             if (s <= send)
2784                 *fpc++ = FF_NEWLINE;
2785             if (noblank) {
2786                 *fpc++ = FF_BLANK;
2787                 if (repeat)
2788                     arg = fpc - linepc + 1;
2789                 else
2790                     arg = 0;
2791                 *fpc++ = arg;
2792             }
2793             if (s < send) {
2794                 linepc = fpc;
2795                 *fpc++ = FF_LINEMARK;
2796                 noblank = repeat = FALSE;
2797                 base = s;
2798             }
2799             else
2800                 s++;
2801             continue;
2802
2803         case '@':
2804         case '^':
2805             ischop = s[-1] == '^';
2806
2807             if (postspace) {
2808                 *fpc++ = FF_SPACE;
2809                 postspace = FALSE;
2810             }
2811             arg = (s - base) - 1;
2812             if (arg) {
2813                 *fpc++ = FF_LITERAL;
2814                 *fpc++ = arg;
2815             }
2816
2817             base = s - 1;
2818             *fpc++ = FF_FETCH;
2819             if (*s == '*') {
2820                 s++;
2821                 *fpc++ = 0;
2822                 *fpc++ = FF_LINEGLOB;
2823             }
2824             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2825                 arg = ischop ? 512 : 0;
2826                 base = s - 1;
2827                 while (*s == '#')
2828                     s++;
2829                 if (*s == '.') {
2830                     char *f;
2831                     s++;
2832                     f = s;
2833                     while (*s == '#')
2834                         s++;
2835                     arg |= 256 + (s - f);
2836                 }
2837                 *fpc++ = s - base;              /* fieldsize for FETCH */
2838                 *fpc++ = FF_DECIMAL;
2839                 *fpc++ = arg;
2840             }
2841             else {
2842                 I32 prespace = 0;
2843                 bool ismore = FALSE;
2844
2845                 if (*s == '>') {
2846                     while (*++s == '>') ;
2847                     prespace = FF_SPACE;
2848                 }
2849                 else if (*s == '|') {
2850                     while (*++s == '|') ;
2851                     prespace = FF_HALFSPACE;
2852                     postspace = TRUE;
2853                 }
2854                 else {
2855                     if (*s == '<')
2856                         while (*++s == '<') ;
2857                     postspace = TRUE;
2858                 }
2859                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2860                     s += 3;
2861                     ismore = TRUE;
2862                 }
2863                 *fpc++ = s - base;              /* fieldsize for FETCH */
2864
2865                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2866
2867                 if (prespace)
2868                     *fpc++ = prespace;
2869                 *fpc++ = FF_ITEM;
2870                 if (ismore)
2871                     *fpc++ = FF_MORE;
2872                 if (ischop)
2873                     *fpc++ = FF_CHOP;
2874             }
2875             base = s;
2876             skipspaces = 0;
2877             continue;
2878         }
2879     }
2880     *fpc++ = FF_END;
2881
2882     arg = fpc - fops;
2883     { /* need to jump to the next word */
2884         int z;
2885         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2886         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2887         s = SvPVX(sv) + SvCUR(sv) + z;
2888     }
2889     Copy(fops, s, arg, U16);
2890     Safefree(fops);
2891     sv_magic(sv, Nullsv, 'f', Nullch, 0);
2892     SvCOMPILED_on(sv);
2893 }
2894
2895 /*
2896  * The rest of this file was derived from source code contributed
2897  * by Tom Horsley.
2898  *
2899  * NOTE: this code was derived from Tom Horsley's qsort replacement
2900  * and should not be confused with the original code.
2901  */
2902
2903 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2904
2905    Permission granted to distribute under the same terms as perl which are
2906    (briefly):
2907
2908     This program is free software; you can redistribute it and/or modify
2909     it under the terms of either:
2910
2911         a) the GNU General Public License as published by the Free
2912         Software Foundation; either version 1, or (at your option) any
2913         later version, or
2914
2915         b) the "Artistic License" which comes with this Kit.
2916
2917    Details on the perl license can be found in the perl source code which
2918    may be located via the www.perl.com web page.
2919
2920    This is the most wonderfulest possible qsort I can come up with (and
2921    still be mostly portable) My (limited) tests indicate it consistently
2922    does about 20% fewer calls to compare than does the qsort in the Visual
2923    C++ library, other vendors may vary.
2924
2925    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2926    others I invented myself (or more likely re-invented since they seemed
2927    pretty obvious once I watched the algorithm operate for a while).
2928
2929    Most of this code was written while watching the Marlins sweep the Giants
2930    in the 1997 National League Playoffs - no Braves fans allowed to use this
2931    code (just kidding :-).
2932
2933    I realize that if I wanted to be true to the perl tradition, the only
2934    comment in this file would be something like:
2935
2936    ...they shuffled back towards the rear of the line. 'No, not at the
2937    rear!'  the slave-driver shouted. 'Three files up. And stay there...
2938
2939    However, I really needed to violate that tradition just so I could keep
2940    track of what happens myself, not to mention some poor fool trying to
2941    understand this years from now :-).
2942 */
2943
2944 /* ********************************************************** Configuration */
2945
2946 #ifndef QSORT_ORDER_GUESS
2947 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
2948 #endif
2949
2950 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
2951    future processing - a good max upper bound is log base 2 of memory size
2952    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
2953    safely be smaller than that since the program is taking up some space and
2954    most operating systems only let you grab some subset of contiguous
2955    memory (not to mention that you are normally sorting data larger than
2956    1 byte element size :-).
2957 */
2958 #ifndef QSORT_MAX_STACK
2959 #define QSORT_MAX_STACK 32
2960 #endif
2961
2962 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
2963    Anything bigger and we use qsort. If you make this too small, the qsort
2964    will probably break (or become less efficient), because it doesn't expect
2965    the middle element of a partition to be the same as the right or left -
2966    you have been warned).
2967 */
2968 #ifndef QSORT_BREAK_EVEN
2969 #define QSORT_BREAK_EVEN 6
2970 #endif
2971
2972 /* ************************************************************* Data Types */
2973
2974 /* hold left and right index values of a partition waiting to be sorted (the
2975    partition includes both left and right - right is NOT one past the end or
2976    anything like that).
2977 */
2978 struct partition_stack_entry {
2979    int left;
2980    int right;
2981 #ifdef QSORT_ORDER_GUESS
2982    int qsort_break_even;
2983 #endif
2984 };
2985
2986 /* ******************************************************* Shorthand Macros */
2987
2988 /* Note that these macros will be used from inside the qsort function where
2989    we happen to know that the variable 'elt_size' contains the size of an
2990    array element and the variable 'temp' points to enough space to hold a
2991    temp element and the variable 'array' points to the array being sorted
2992    and 'compare' is the pointer to the compare routine.
2993
2994    Also note that there are very many highly architecture specific ways
2995    these might be sped up, but this is simply the most generally portable
2996    code I could think of.
2997 */
2998
2999 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3000 */
3001 #define qsort_cmp(elt1, elt2) \
3002    ((*compare)(array[elt1], array[elt2]))
3003
3004 #ifdef QSORT_ORDER_GUESS
3005 #define QSORT_NOTICE_SWAP swapped++;
3006 #else
3007 #define QSORT_NOTICE_SWAP
3008 #endif
3009
3010 /* swaps contents of array elements elt1, elt2.
3011 */
3012 #define qsort_swap(elt1, elt2) \
3013    STMT_START { \
3014       QSORT_NOTICE_SWAP \
3015       temp = array[elt1]; \
3016       array[elt1] = array[elt2]; \
3017       array[elt2] = temp; \
3018    } STMT_END
3019
3020 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3021    elt3 and elt3 gets elt1.
3022 */
3023 #define qsort_rotate(elt1, elt2, elt3) \
3024    STMT_START { \
3025       QSORT_NOTICE_SWAP \
3026       temp = array[elt1]; \
3027       array[elt1] = array[elt2]; \
3028       array[elt2] = array[elt3]; \
3029       array[elt3] = temp; \
3030    } STMT_END
3031
3032 /* ************************************************************ Debug stuff */
3033
3034 #ifdef QSORT_DEBUG
3035
3036 static void
3037 break_here()
3038 {
3039    return; /* good place to set a breakpoint */
3040 }
3041
3042 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3043
3044 static void
3045 doqsort_all_asserts(
3046    void * array,
3047    size_t num_elts,
3048    size_t elt_size,
3049    int (*compare)(const void * elt1, const void * elt2),
3050    int pc_left, int pc_right, int u_left, int u_right)
3051 {
3052    int i;
3053
3054    qsort_assert(pc_left <= pc_right);
3055    qsort_assert(u_right < pc_left);
3056    qsort_assert(pc_right < u_left);
3057    for (i = u_right + 1; i < pc_left; ++i) {
3058       qsort_assert(qsort_cmp(i, pc_left) < 0);
3059    }
3060    for (i = pc_left; i < pc_right; ++i) {
3061       qsort_assert(qsort_cmp(i, pc_right) == 0);
3062    }
3063    for (i = pc_right + 1; i < u_left; ++i) {
3064       qsort_assert(qsort_cmp(pc_right, i) < 0);
3065    }
3066 }
3067
3068 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3069    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3070                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3071
3072 #else
3073
3074 #define qsort_assert(t) ((void)0)
3075
3076 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3077
3078 #endif
3079
3080 /* ****************************************************************** qsort */
3081
3082 void
3083 qsortsv(
3084    SV ** array,
3085    size_t num_elts,
3086    I32 (*compare)(SV *a, SV *b))
3087 {
3088    register SV * temp;
3089
3090    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3091    int next_stack_entry = 0;
3092
3093    int part_left;
3094    int part_right;
3095 #ifdef QSORT_ORDER_GUESS
3096    int qsort_break_even;
3097    int swapped;
3098 #endif
3099
3100    /* Make sure we actually have work to do.
3101    */
3102    if (num_elts <= 1) {
3103       return;
3104    }
3105
3106    /* Setup the initial partition definition and fall into the sorting loop
3107    */
3108    part_left = 0;
3109    part_right = (int)(num_elts - 1);
3110 #ifdef QSORT_ORDER_GUESS
3111    qsort_break_even = QSORT_BREAK_EVEN;
3112 #else
3113 #define qsort_break_even QSORT_BREAK_EVEN
3114 #endif
3115    for ( ; ; ) {
3116       if ((part_right - part_left) >= qsort_break_even) {
3117          /* OK, this is gonna get hairy, so lets try to document all the
3118             concepts and abbreviations and variables and what they keep
3119             track of:
3120
3121             pc: pivot chunk - the set of array elements we accumulate in the
3122                 middle of the partition, all equal in value to the original
3123                 pivot element selected. The pc is defined by:
3124
3125                 pc_left - the leftmost array index of the pc
3126                 pc_right - the rightmost array index of the pc
3127
3128                 we start with pc_left == pc_right and only one element
3129                 in the pivot chunk (but it can grow during the scan).
3130
3131             u:  uncompared elements - the set of elements in the partition
3132                 we have not yet compared to the pivot value. There are two
3133                 uncompared sets during the scan - one to the left of the pc
3134                 and one to the right.
3135
3136                 u_right - the rightmost index of the left side's uncompared set
3137                 u_left - the leftmost index of the right side's uncompared set
3138
3139                 The leftmost index of the left sides's uncompared set
3140                 doesn't need its own variable because it is always defined
3141                 by the leftmost edge of the whole partition (part_left). The
3142                 same goes for the rightmost edge of the right partition
3143                 (part_right).
3144
3145                 We know there are no uncompared elements on the left once we
3146                 get u_right < part_left and no uncompared elements on the
3147                 right once u_left > part_right. When both these conditions
3148                 are met, we have completed the scan of the partition.
3149
3150                 Any elements which are between the pivot chunk and the
3151                 uncompared elements should be less than the pivot value on
3152                 the left side and greater than the pivot value on the right
3153                 side (in fact, the goal of the whole algorithm is to arrange
3154                 for that to be true and make the groups of less-than and
3155                 greater-then elements into new partitions to sort again).
3156
3157             As you marvel at the complexity of the code and wonder why it
3158             has to be so confusing. Consider some of the things this level
3159             of confusion brings:
3160
3161             Once I do a compare, I squeeze every ounce of juice out of it. I
3162             never do compare calls I don't have to do, and I certainly never
3163             do redundant calls.
3164
3165             I also never swap any elements unless I can prove there is a
3166             good reason. Many sort algorithms will swap a known value with
3167             an uncompared value just to get things in the right place (or
3168             avoid complexity :-), but that uncompared value, once it gets
3169             compared, may then have to be swapped again. A lot of the
3170             complexity of this code is due to the fact that it never swaps
3171             anything except compared values, and it only swaps them when the
3172             compare shows they are out of position.
3173          */
3174          int pc_left, pc_right;
3175          int u_right, u_left;
3176
3177          int s;
3178
3179          pc_left = ((part_left + part_right) / 2);
3180          pc_right = pc_left;
3181          u_right = pc_left - 1;
3182          u_left = pc_right + 1;
3183
3184          /* Qsort works best when the pivot value is also the median value
3185             in the partition (unfortunately you can't find the median value
3186             without first sorting :-), so to give the algorithm a helping
3187             hand, we pick 3 elements and sort them and use the median value
3188             of that tiny set as the pivot value.
3189
3190             Some versions of qsort like to use the left middle and right as
3191             the 3 elements to sort so they can insure the ends of the
3192             partition will contain values which will stop the scan in the
3193             compare loop, but when you have to call an arbitrarily complex
3194             routine to do a compare, its really better to just keep track of
3195             array index values to know when you hit the edge of the
3196             partition and avoid the extra compare. An even better reason to
3197             avoid using a compare call is the fact that you can drop off the
3198             edge of the array if someone foolishly provides you with an
3199             unstable compare function that doesn't always provide consistent
3200             results.
3201
3202             So, since it is simpler for us to compare the three adjacent
3203             elements in the middle of the partition, those are the ones we
3204             pick here (conveniently pointed at by u_right, pc_left, and
3205             u_left). The values of the left, center, and right elements
3206             are refered to as l c and r in the following comments.
3207          */
3208
3209 #ifdef QSORT_ORDER_GUESS
3210          swapped = 0;
3211 #endif
3212          s = qsort_cmp(u_right, pc_left);
3213          if (s < 0) {
3214             /* l < c */
3215             s = qsort_cmp(pc_left, u_left);
3216             /* if l < c, c < r - already in order - nothing to do */
3217             if (s == 0) {
3218                /* l < c, c == r - already in order, pc grows */
3219                ++pc_right;
3220                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3221             } else if (s > 0) {
3222                /* l < c, c > r - need to know more */
3223                s = qsort_cmp(u_right, u_left);
3224                if (s < 0) {
3225                   /* l < c, c > r, l < r - swap c & r to get ordered */
3226                   qsort_swap(pc_left, u_left);
3227                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3228                } else if (s == 0) {
3229                   /* l < c, c > r, l == r - swap c&r, grow pc */
3230                   qsort_swap(pc_left, u_left);
3231                   --pc_left;
3232                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3233                } else {
3234                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3235                   qsort_rotate(pc_left, u_right, u_left);
3236                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3237                }
3238             }
3239          } else if (s == 0) {
3240             /* l == c */
3241             s = qsort_cmp(pc_left, u_left);
3242             if (s < 0) {
3243                /* l == c, c < r - already in order, grow pc */
3244                --pc_left;
3245                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3246             } else if (s == 0) {
3247                /* l == c, c == r - already in order, grow pc both ways */
3248                --pc_left;
3249                ++pc_right;
3250                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3251             } else {
3252                /* l == c, c > r - swap l & r, grow pc */
3253                qsort_swap(u_right, u_left);
3254                ++pc_right;
3255                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3256             }
3257          } else {
3258             /* l > c */
3259             s = qsort_cmp(pc_left, u_left);
3260             if (s < 0) {
3261                /* l > c, c < r - need to know more */
3262                s = qsort_cmp(u_right, u_left);
3263                if (s < 0) {
3264                   /* l > c, c < r, l < r - swap l & c to get ordered */
3265                   qsort_swap(u_right, pc_left);
3266                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3267                } else if (s == 0) {
3268                   /* l > c, c < r, l == r - swap l & c, grow pc */
3269                   qsort_swap(u_right, pc_left);
3270                   ++pc_right;
3271                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3272                } else {
3273                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3274                   qsort_rotate(u_right, pc_left, u_left);
3275                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3276                }
3277             } else if (s == 0) {
3278                /* l > c, c == r - swap ends, grow pc */
3279                qsort_swap(u_right, u_left);
3280                --pc_left;
3281                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3282             } else {
3283                /* l > c, c > r - swap ends to get in order */
3284                qsort_swap(u_right, u_left);
3285                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3286             }
3287          }
3288          /* We now know the 3 middle elements have been compared and
3289             arranged in the desired order, so we can shrink the uncompared
3290             sets on both sides
3291          */
3292          --u_right;
3293          ++u_left;
3294          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3295
3296          /* The above massive nested if was the simple part :-). We now have
3297             the middle 3 elements ordered and we need to scan through the
3298             uncompared sets on either side, swapping elements that are on
3299             the wrong side or simply shuffling equal elements around to get
3300             all equal elements into the pivot chunk.
3301          */
3302
3303          for ( ; ; ) {
3304             int still_work_on_left;
3305             int still_work_on_right;
3306
3307             /* Scan the uncompared values on the left. If I find a value
3308                equal to the pivot value, move it over so it is adjacent to
3309                the pivot chunk and expand the pivot chunk. If I find a value
3310                less than the pivot value, then just leave it - its already
3311                on the correct side of the partition. If I find a greater
3312                value, then stop the scan.
3313             */
3314             while (still_work_on_left = (u_right >= part_left)) {
3315                s = qsort_cmp(u_right, pc_left);
3316                if (s < 0) {
3317                   --u_right;
3318                } else if (s == 0) {
3319                   --pc_left;
3320                   if (pc_left != u_right) {
3321                      qsort_swap(u_right, pc_left);
3322                   }
3323                   --u_right;
3324                } else {
3325                   break;
3326                }
3327                qsort_assert(u_right < pc_left);
3328                qsort_assert(pc_left <= pc_right);
3329                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3330                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3331             }
3332
3333             /* Do a mirror image scan of uncompared values on the right
3334             */
3335             while (still_work_on_right = (u_left <= part_right)) {
3336                s = qsort_cmp(pc_right, u_left);
3337                if (s < 0) {
3338                   ++u_left;
3339                } else if (s == 0) {
3340                   ++pc_right;
3341                   if (pc_right != u_left) {
3342                      qsort_swap(pc_right, u_left);
3343                   }
3344                   ++u_left;
3345                } else {
3346                   break;
3347                }
3348                qsort_assert(u_left > pc_right);
3349                qsort_assert(pc_left <= pc_right);
3350                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3351                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3352             }
3353
3354             if (still_work_on_left) {
3355                /* I know I have a value on the left side which needs to be
3356                   on the right side, but I need to know more to decide
3357                   exactly the best thing to do with it.
3358                */
3359                if (still_work_on_right) {
3360                   /* I know I have values on both side which are out of
3361                      position. This is a big win because I kill two birds
3362                      with one swap (so to speak). I can advance the
3363                      uncompared pointers on both sides after swapping both
3364                      of them into the right place.
3365                   */
3366                   qsort_swap(u_right, u_left);
3367                   --u_right;
3368                   ++u_left;
3369                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3370                } else {
3371                   /* I have an out of position value on the left, but the
3372                      right is fully scanned, so I "slide" the pivot chunk
3373                      and any less-than values left one to make room for the
3374                      greater value over on the right. If the out of position
3375                      value is immediately adjacent to the pivot chunk (there
3376                      are no less-than values), I can do that with a swap,
3377                      otherwise, I have to rotate one of the less than values
3378                      into the former position of the out of position value
3379                      and the right end of the pivot chunk into the left end
3380                      (got all that?).
3381                   */
3382                   --pc_left;
3383                   if (pc_left == u_right) {
3384                      qsort_swap(u_right, pc_right);
3385                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3386                   } else {
3387                      qsort_rotate(u_right, pc_left, pc_right);
3388                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3389                   }
3390                   --pc_right;
3391                   --u_right;
3392                }
3393             } else if (still_work_on_right) {
3394                /* Mirror image of complex case above: I have an out of
3395                   position value on the right, but the left is fully
3396                   scanned, so I need to shuffle things around to make room
3397                   for the right value on the left.
3398                */
3399                ++pc_right;
3400                if (pc_right == u_left) {
3401                   qsort_swap(u_left, pc_left);
3402                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3403                } else {
3404                   qsort_rotate(pc_right, pc_left, u_left);
3405                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3406                }
3407                ++pc_left;
3408                ++u_left;
3409             } else {
3410                /* No more scanning required on either side of partition,
3411                   break out of loop and figure out next set of partitions
3412                */
3413                break;
3414             }
3415          }
3416
3417          /* The elements in the pivot chunk are now in the right place. They
3418             will never move or be compared again. All I have to do is decide
3419             what to do with the stuff to the left and right of the pivot
3420             chunk.
3421
3422             Notes on the QSORT_ORDER_GUESS ifdef code:
3423
3424             1. If I just built these partitions without swapping any (or
3425                very many) elements, there is a chance that the elements are
3426                already ordered properly (being properly ordered will
3427                certainly result in no swapping, but the converse can't be
3428                proved :-).
3429
3430             2. A (properly written) insertion sort will run faster on
3431                already ordered data than qsort will.
3432
3433             3. Perhaps there is some way to make a good guess about
3434                switching to an insertion sort earlier than partition size 6
3435                (for instance - we could save the partition size on the stack
3436                and increase the size each time we find we didn't swap, thus
3437                switching to insertion sort earlier for partitions with a
3438                history of not swapping).
3439
3440             4. Naturally, if I just switch right away, it will make
3441                artificial benchmarks with pure ascending (or descending)
3442                data look really good, but is that a good reason in general?
3443                Hard to say...
3444          */
3445
3446 #ifdef QSORT_ORDER_GUESS
3447          if (swapped < 3) {
3448 #if QSORT_ORDER_GUESS == 1
3449             qsort_break_even = (part_right - part_left) + 1;
3450 #endif
3451 #if QSORT_ORDER_GUESS == 2
3452             qsort_break_even *= 2;
3453 #endif
3454 #if QSORT_ORDER_GUESS == 3
3455             int prev_break = qsort_break_even;
3456             qsort_break_even *= qsort_break_even;
3457             if (qsort_break_even < prev_break) {
3458                qsort_break_even = (part_right - part_left) + 1;
3459             }
3460 #endif
3461          } else {
3462             qsort_break_even = QSORT_BREAK_EVEN;
3463          }
3464 #endif
3465
3466          if (part_left < pc_left) {
3467             /* There are elements on the left which need more processing.
3468                Check the right as well before deciding what to do.
3469             */
3470             if (pc_right < part_right) {
3471                /* We have two partitions to be sorted. Stack the biggest one
3472                   and process the smallest one on the next iteration. This
3473                   minimizes the stack height by insuring that any additional
3474                   stack entries must come from the smallest partition which
3475                   (because it is smallest) will have the fewest
3476                   opportunities to generate additional stack entries.
3477                */
3478                if ((part_right - pc_right) > (pc_left - part_left)) {
3479                   /* stack the right partition, process the left */
3480                   partition_stack[next_stack_entry].left = pc_right + 1;
3481                   partition_stack[next_stack_entry].right = part_right;
3482 #ifdef QSORT_ORDER_GUESS
3483                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3484 #endif
3485                   part_right = pc_left - 1;
3486                } else {
3487                   /* stack the left partition, process the right */
3488                   partition_stack[next_stack_entry].left = part_left;
3489                   partition_stack[next_stack_entry].right = pc_left - 1;
3490 #ifdef QSORT_ORDER_GUESS
3491                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3492 #endif
3493                   part_left = pc_right + 1;
3494                }
3495                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3496                ++next_stack_entry;
3497             } else {
3498                /* The elements on the left are the only remaining elements
3499                   that need sorting, arrange for them to be processed as the
3500                   next partition.
3501                */
3502                part_right = pc_left - 1;
3503             }
3504          } else if (pc_right < part_right) {
3505             /* There is only one chunk on the right to be sorted, make it
3506                the new partition and loop back around.
3507             */
3508             part_left = pc_right + 1;
3509          } else {
3510             /* This whole partition wound up in the pivot chunk, so
3511                we need to get a new partition off the stack.
3512             */
3513             if (next_stack_entry == 0) {
3514                /* the stack is empty - we are done */
3515                break;
3516             }
3517             --next_stack_entry;
3518             part_left = partition_stack[next_stack_entry].left;
3519             part_right = partition_stack[next_stack_entry].right;
3520 #ifdef QSORT_ORDER_GUESS
3521             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3522 #endif
3523          }
3524       } else {
3525          /* This partition is too small to fool with qsort complexity, just
3526             do an ordinary insertion sort to minimize overhead.
3527          */
3528          int i;
3529          /* Assume 1st element is in right place already, and start checking
3530             at 2nd element to see where it should be inserted.
3531          */
3532          for (i = part_left + 1; i <= part_right; ++i) {
3533             int j;
3534             /* Scan (backwards - just in case 'i' is already in right place)
3535                through the elements already sorted to see if the ith element
3536                belongs ahead of one of them.
3537             */
3538             for (j = i - 1; j >= part_left; --j) {
3539                if (qsort_cmp(i, j) >= 0) {
3540                   /* i belongs right after j
3541                   */
3542                   break;
3543                }
3544             }
3545             ++j;
3546             if (j != i) {
3547                /* Looks like we really need to move some things
3548                */
3549                temp = array[i];
3550                for (--i; i >= j; --i)
3551                   array[i + 1] = array[i];
3552                array[j] = temp;
3553             }
3554          }
3555
3556          /* That partition is now sorted, grab the next one, or get out
3557             of the loop if there aren't any more.
3558          */
3559
3560          if (next_stack_entry == 0) {
3561             /* the stack is empty - we are done */
3562             break;
3563          }
3564          --next_stack_entry;
3565          part_left = partition_stack[next_stack_entry].left;
3566          part_right = partition_stack[next_stack_entry].right;
3567 #ifdef QSORT_ORDER_GUESS
3568          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3569 #endif
3570       }
3571    }
3572
3573    /* Believe it or not, the array is sorted at this point! */
3574 }