pp_ctl.c

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