pp_ctl.c

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