pp_ctl.c

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