pp_ctl.c

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