pp_ctl.c

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