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