pp_ctl.c

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