pp_ctl.c

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