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