pp_ctl.c

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