pp_ctl.c

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