pp_ctl.c

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