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