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