pp_ctl.c

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