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