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