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 = pregcomp(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 || !regexec_flags(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(SI_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             }
1392             else
1393                 cx->blk_loop.iterlval = newSVsv(sv);
1394         }
1395     }
1396     else {
1397         cx->blk_loop.iterary = curstack;
1398         AvFILLp(curstack) = SP - stack_base;
1399         cx->blk_loop.iterix = MARK - stack_base;
1400     }
1401
1402     RETURN;
1403 }
1404
1405 PP(pp_enterloop)
1406 {
1407     djSP;
1408     register PERL_CONTEXT *cx;
1409     I32 gimme = GIMME_V;
1410
1411     ENTER;
1412     SAVETMPS;
1413     ENTER;
1414
1415     PUSHBLOCK(cx, CXt_LOOP, SP);
1416     PUSHLOOP(cx, 0, SP);
1417
1418     RETURN;
1419 }
1420
1421 PP(pp_leaveloop)
1422 {
1423     djSP;
1424     register PERL_CONTEXT *cx;
1425     struct block_loop cxloop;
1426     I32 gimme;
1427     SV **newsp;
1428     PMOP *newpm;
1429     SV **mark;
1430
1431     POPBLOCK(cx,newpm);
1432     mark = newsp;
1433     POPLOOP1(cx);       /* Delay POPLOOP2 until stack values are safe */
1434
1435     TAINT_NOT;
1436     if (gimme == G_VOID)
1437         ; /* do nothing */
1438     else if (gimme == G_SCALAR) {
1439         if (mark < SP)
1440             *++newsp = sv_mortalcopy(*SP);
1441         else
1442             *++newsp = &sv_undef;
1443     }
1444     else {
1445         while (mark < SP) {
1446             *++newsp = sv_mortalcopy(*++mark);
1447             TAINT_NOT;          /* Each item is independent */
1448         }
1449     }
1450     SP = newsp;
1451     PUTBACK;
1452
1453     POPLOOP2();         /* Stack values are safe: release loop vars ... */
1454     curpm = newpm;      /* ... and pop $1 et al */
1455
1456     LEAVE;
1457     LEAVE;
1458
1459     return NORMAL;
1460 }
1461
1462 PP(pp_return)
1463 {
1464     djSP; dMARK;
1465     I32 cxix;
1466     register PERL_CONTEXT *cx;
1467     struct block_sub cxsub;
1468     bool popsub2 = FALSE;
1469     I32 gimme;
1470     SV **newsp;
1471     PMOP *newpm;
1472     I32 optype = 0;
1473
1474     if (curstackinfo->si_type == SI_SORT) {
1475         if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1476             if (cxstack_ix > sortcxix)
1477                 dounwind(sortcxix);
1478             AvARRAY(curstack)[1] = *SP;
1479             stack_sp = stack_base + 1;
1480             return 0;
1481         }
1482     }
1483
1484     cxix = dopoptosub(cxstack_ix);
1485     if (cxix < 0)
1486         DIE("Can't return outside a subroutine");
1487     if (cxix < cxstack_ix)
1488         dounwind(cxix);
1489
1490     POPBLOCK(cx,newpm);
1491     switch (cx->cx_type) {
1492     case CXt_SUB:
1493         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1494         popsub2 = TRUE;
1495         break;
1496     case CXt_EVAL:
1497         POPEVAL(cx);
1498         if (optype == OP_REQUIRE &&
1499             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1500         {
1501             /* Unassume the success we assumed earlier. */
1502             char *name = cx->blk_eval.old_name;
1503             (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1504             DIE("%s did not return a true value", name);
1505         }
1506         break;
1507     default:
1508         DIE("panic: return");
1509     }
1510
1511     TAINT_NOT;
1512     if (gimme == G_SCALAR) {
1513         if (MARK < SP) {
1514             if (popsub2) {
1515                 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1516                     if (SvTEMP(TOPs)) {
1517                         *++newsp = SvREFCNT_inc(*SP);
1518                         FREETMPS;
1519                         sv_2mortal(*newsp);
1520                     } else {
1521                         FREETMPS;
1522                         *++newsp = sv_mortalcopy(*SP);
1523                     }
1524                 } else
1525                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1526             } else
1527                 *++newsp = sv_mortalcopy(*SP);
1528         } else
1529             *++newsp = &sv_undef;
1530     }
1531     else if (gimme == G_ARRAY) {
1532         while (++MARK <= SP) {
1533             *++newsp = (popsub2 && SvTEMP(*MARK))
1534                         ? *MARK : sv_mortalcopy(*MARK);
1535             TAINT_NOT;          /* Each item is independent */
1536         }
1537     }
1538     stack_sp = newsp;
1539
1540     /* Stack values are safe: */
1541     if (popsub2) {
1542         POPSUB2();      /* release CV and @_ ... */
1543     }
1544     curpm = newpm;      /* ... and pop $1 et al */
1545
1546     LEAVE;
1547     return pop_return();
1548 }
1549
1550 PP(pp_last)
1551 {
1552     djSP;
1553     I32 cxix;
1554     register PERL_CONTEXT *cx;
1555     struct block_loop cxloop;
1556     struct block_sub cxsub;
1557     I32 pop2 = 0;
1558     I32 gimme;
1559     I32 optype;
1560     OP *nextop;
1561     SV **newsp;
1562     PMOP *newpm;
1563     SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1564
1565     if (op->op_flags & OPf_SPECIAL) {
1566         cxix = dopoptoloop(cxstack_ix);
1567         if (cxix < 0)
1568             DIE("Can't \"last\" outside a block");
1569     }
1570     else {
1571         cxix = dopoptolabel(cPVOP->op_pv);
1572         if (cxix < 0)
1573             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1574     }
1575     if (cxix < cxstack_ix)
1576         dounwind(cxix);
1577
1578     POPBLOCK(cx,newpm);
1579     switch (cx->cx_type) {
1580     case CXt_LOOP:
1581         POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
1582         pop2 = CXt_LOOP;
1583         nextop = cxloop.last_op->op_next;
1584         break;
1585     case CXt_SUB:
1586         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1587         pop2 = CXt_SUB;
1588         nextop = pop_return();
1589         break;
1590     case CXt_EVAL:
1591         POPEVAL(cx);
1592         nextop = pop_return();
1593         break;
1594     default:
1595         DIE("panic: last");
1596     }
1597
1598     TAINT_NOT;
1599     if (gimme == G_SCALAR) {
1600         if (MARK < SP)
1601             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1602                         ? *SP : sv_mortalcopy(*SP);
1603         else
1604             *++newsp = &sv_undef;
1605     }
1606     else if (gimme == G_ARRAY) {
1607         while (++MARK <= SP) {
1608             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1609                         ? *MARK : sv_mortalcopy(*MARK);
1610             TAINT_NOT;          /* Each item is independent */
1611         }
1612     }
1613     SP = newsp;
1614     PUTBACK;
1615
1616     /* Stack values are safe: */
1617     switch (pop2) {
1618     case CXt_LOOP:
1619         POPLOOP2();     /* release loop vars ... */
1620         LEAVE;
1621         break;
1622     case CXt_SUB:
1623         POPSUB2();      /* release CV and @_ ... */
1624         break;
1625     }
1626     curpm = newpm;      /* ... and pop $1 et al */
1627
1628     LEAVE;
1629     return nextop;
1630 }
1631
1632 PP(pp_next)
1633 {
1634     I32 cxix;
1635     register PERL_CONTEXT *cx;
1636     I32 oldsave;
1637
1638     if (op->op_flags & OPf_SPECIAL) {
1639         cxix = dopoptoloop(cxstack_ix);
1640         if (cxix < 0)
1641             DIE("Can't \"next\" outside a block");
1642     }
1643     else {
1644         cxix = dopoptolabel(cPVOP->op_pv);
1645         if (cxix < 0)
1646             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1647     }
1648     if (cxix < cxstack_ix)
1649         dounwind(cxix);
1650
1651     TOPBLOCK(cx);
1652     oldsave = scopestack[scopestack_ix - 1];
1653     LEAVE_SCOPE(oldsave);
1654     return cx->blk_loop.next_op;
1655 }
1656
1657 PP(pp_redo)
1658 {
1659     I32 cxix;
1660     register PERL_CONTEXT *cx;
1661     I32 oldsave;
1662
1663     if (op->op_flags & OPf_SPECIAL) {
1664         cxix = dopoptoloop(cxstack_ix);
1665         if (cxix < 0)
1666             DIE("Can't \"redo\" outside a block");
1667     }
1668     else {
1669         cxix = dopoptolabel(cPVOP->op_pv);
1670         if (cxix < 0)
1671             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1672     }
1673     if (cxix < cxstack_ix)
1674         dounwind(cxix);
1675
1676     TOPBLOCK(cx);
1677     oldsave = scopestack[scopestack_ix - 1];
1678     LEAVE_SCOPE(oldsave);
1679     return cx->blk_loop.redo_op;
1680 }
1681
1682 STATIC OP *
1683 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1684 {
1685     OP *kid;
1686     OP **ops = opstack;
1687     static char too_deep[] = "Target of goto is too deeply nested";
1688
1689     if (ops >= oplimit)
1690         croak(too_deep);
1691     if (o->op_type == OP_LEAVE ||
1692         o->op_type == OP_SCOPE ||
1693         o->op_type == OP_LEAVELOOP ||
1694         o->op_type == OP_LEAVETRY)
1695     {
1696         *ops++ = cUNOPo->op_first;
1697         if (ops >= oplimit)
1698             croak(too_deep);
1699     }
1700     *ops = 0;
1701     if (o->op_flags & OPf_KIDS) {
1702         /* First try all the kids at this level, since that's likeliest. */
1703         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1704             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1705                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1706                 return kid;
1707         }
1708         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1709             if (kid == lastgotoprobe)
1710                 continue;
1711             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1712                 (ops == opstack ||
1713                  (ops[-1]->op_type != OP_NEXTSTATE &&
1714                   ops[-1]->op_type != OP_DBSTATE)))
1715                 *ops++ = kid;
1716             if (o = dofindlabel(kid, label, ops, oplimit))
1717                 return o;
1718         }
1719     }
1720     *ops = 0;
1721     return 0;
1722 }
1723
1724 PP(pp_dump)
1725 {
1726     return pp_goto(ARGS);
1727     /*NOTREACHED*/
1728 }
1729
1730 PP(pp_goto)
1731 {
1732     djSP;
1733     OP *retop = 0;
1734     I32 ix;
1735     register PERL_CONTEXT *cx;
1736 #define GOTO_DEPTH 64
1737     OP *enterops[GOTO_DEPTH];
1738     char *label;
1739     int do_dump = (op->op_type == OP_DUMP);
1740
1741     label = 0;
1742     if (op->op_flags & OPf_STACKED) {
1743         SV *sv = POPs;
1744
1745         /* This egregious kludge implements goto &subroutine */
1746         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1747             I32 cxix;
1748             register PERL_CONTEXT *cx;
1749             CV* cv = (CV*)SvRV(sv);
1750             SV** mark;
1751             I32 items = 0;
1752             I32 oldsave;
1753
1754             if (!CvROOT(cv) && !CvXSUB(cv)) {
1755                 if (CvGV(cv)) {
1756                     SV *tmpstr = sv_newmortal();
1757                     gv_efullname3(tmpstr, CvGV(cv), Nullch);
1758                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1759                 }
1760                 DIE("Goto undefined subroutine");
1761             }
1762
1763             /* First do some returnish stuff. */
1764             cxix = dopoptosub(cxstack_ix);
1765             if (cxix < 0)
1766                 DIE("Can't goto subroutine outside a subroutine");
1767             if (cxix < cxstack_ix)
1768                 dounwind(cxix);
1769             TOPBLOCK(cx);
1770             if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1771                 DIE("Can't goto subroutine from an eval-string");
1772             mark = stack_sp;
1773             if (cx->cx_type == CXt_SUB &&
1774                 cx->blk_sub.hasargs) {   /* put @_ back onto stack */
1775                 AV* av = cx->blk_sub.argarray;
1776
1777                 items = AvFILLp(av) + 1;
1778                 stack_sp++;
1779                 EXTEND(stack_sp, items); /* @_ could have been extended. */
1780                 Copy(AvARRAY(av), stack_sp, items, SV*);
1781                 stack_sp += items;
1782 #ifndef USE_THREADS
1783                 SvREFCNT_dec(GvAV(defgv));
1784                 GvAV(defgv) = cx->blk_sub.savearray;
1785 #endif /* USE_THREADS */
1786                 AvREAL_off(av);
1787                 av_clear(av);
1788             }
1789             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
1790                 AV* av;
1791                 int i;
1792 #ifdef USE_THREADS
1793                 av = (AV*)curpad[0];
1794 #else
1795                 av = GvAV(defgv);
1796 #endif
1797                 items = AvFILLp(av) + 1;
1798                 stack_sp++;
1799                 EXTEND(stack_sp, items); /* @_ could have been extended. */
1800                 Copy(AvARRAY(av), stack_sp, items, SV*);
1801                 stack_sp += items;
1802             }
1803             if (cx->cx_type == CXt_SUB &&
1804                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1805                 SvREFCNT_dec(cx->blk_sub.cv);
1806             oldsave = scopestack[scopestack_ix - 1];
1807             LEAVE_SCOPE(oldsave);
1808
1809             /* Now do some callish stuff. */
1810             SAVETMPS;
1811             if (CvXSUB(cv)) {
1812                 if (CvOLDSTYLE(cv)) {
1813                     I32 (*fp3)_((int,int,int));
1814                     while (SP > mark) {
1815                         SP[1] = SP[0];
1816                         SP--;
1817                     }
1818                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1819                     items = (*fp3)(CvXSUBANY(cv).any_i32,
1820                                    mark - stack_base + 1,
1821                                    items);
1822                     SP = stack_base + items;
1823                 }
1824                 else {
1825                     SV **newsp;
1826                     I32 gimme;
1827
1828                     stack_sp--;         /* There is no cv arg. */
1829                     /* Push a mark for the start of arglist */
1830                     PUSHMARK(mark);
1831                     (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1832                     /* Pop the current context like a decent sub should */
1833                     POPBLOCK(cx, curpm);
1834                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1835                 }
1836                 LEAVE;
1837                 return pop_return();
1838             }
1839             else {
1840                 AV* padlist = CvPADLIST(cv);
1841                 SV** svp = AvARRAY(padlist);
1842                 if (cx->cx_type == CXt_EVAL) {
1843                     in_eval = cx->blk_eval.old_in_eval;
1844                     eval_root = cx->blk_eval.old_eval_root;
1845                     cx->cx_type = CXt_SUB;
1846                     cx->blk_sub.hasargs = 0;
1847                 }
1848                 cx->blk_sub.cv = cv;
1849                 cx->blk_sub.olddepth = CvDEPTH(cv);
1850                 CvDEPTH(cv)++;
1851                 if (CvDEPTH(cv) < 2)
1852                     (void)SvREFCNT_inc(cv);
1853                 else {  /* save temporaries on recursion? */
1854                     if (CvDEPTH(cv) == 100 && dowarn)
1855                         sub_crush_depth(cv);
1856                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
1857                         AV *newpad = newAV();
1858                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1859                         I32 ix = AvFILLp((AV*)svp[1]);
1860                         svp = AvARRAY(svp[0]);
1861                         for ( ;ix > 0; ix--) {
1862                             if (svp[ix] != &sv_undef) {
1863                                 char *name = SvPVX(svp[ix]);
1864                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1865                                     || *name == '&')
1866                                 {
1867                                     /* outer lexical or anon code */
1868                                     av_store(newpad, ix,
1869                                         SvREFCNT_inc(oldpad[ix]) );
1870                                 }
1871                                 else {          /* our own lexical */
1872                                     if (*name == '@')
1873                                         av_store(newpad, ix, sv = (SV*)newAV());
1874                                     else if (*name == '%')
1875                                         av_store(newpad, ix, sv = (SV*)newHV());
1876                                     else
1877                                         av_store(newpad, ix, sv = NEWSV(0,0));
1878                                     SvPADMY_on(sv);
1879                                 }
1880                             }
1881                             else {
1882                                 av_store(newpad, ix, sv = NEWSV(0,0));
1883                                 SvPADTMP_on(sv);
1884                             }
1885                         }
1886                         if (cx->blk_sub.hasargs) {
1887                             AV* av = newAV();
1888                             av_extend(av, 0);
1889                             av_store(newpad, 0, (SV*)av);
1890                             AvFLAGS(av) = AVf_REIFY;
1891                         }
1892                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1893                         AvFILLp(padlist) = CvDEPTH(cv);
1894                         svp = AvARRAY(padlist);
1895                     }
1896                 }
1897 #ifdef USE_THREADS
1898                 if (!cx->blk_sub.hasargs) {
1899                     AV* av = (AV*)curpad[0];
1900
1901                     items = AvFILLp(av) + 1;
1902                     if (items) {
1903                         /* Mark is at the end of the stack. */
1904                         EXTEND(SP, items);
1905                         Copy(AvARRAY(av), SP + 1, items, SV*);
1906                         SP += items;
1907                         PUTBACK ;
1908                     }
1909                 }
1910 #endif /* USE_THREADS */
1911                 SAVESPTR(curpad);
1912                 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1913 #ifndef USE_THREADS
1914                 if (cx->blk_sub.hasargs)
1915 #endif /* USE_THREADS */
1916                 {
1917                     AV* av = (AV*)curpad[0];
1918                     SV** ary;
1919
1920 #ifndef USE_THREADS
1921                     cx->blk_sub.savearray = GvAV(defgv);
1922                     GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1923 #endif /* USE_THREADS */
1924                     cx->blk_sub.argarray = av;
1925                     ++mark;
1926
1927                     if (items >= AvMAX(av) + 1) {
1928                         ary = AvALLOC(av);
1929                         if (AvARRAY(av) != ary) {
1930                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1931                             SvPVX(av) = (char*)ary;
1932                         }
1933                         if (items >= AvMAX(av) + 1) {
1934                             AvMAX(av) = items - 1;
1935                             Renew(ary,items+1,SV*);
1936                             AvALLOC(av) = ary;
1937                             SvPVX(av) = (char*)ary;
1938                         }
1939                     }
1940                     Copy(mark,AvARRAY(av),items,SV*);
1941                     AvFILLp(av) = items - 1;
1942
1943                     while (items--) {
1944                         if (*mark)
1945                             SvTEMP_off(*mark);
1946                         mark++;
1947                     }
1948                 }
1949                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
1950                     /*
1951                      * We do not care about using sv to call CV;
1952                      * it's for informational purposes only.
1953                      */
1954                     SV *sv = GvSV(DBsub);
1955                     CV *gotocv;
1956
1957                     if (PERLDB_SUB_NN) {
1958                         SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1959                     } else {
1960                         save_item(sv);
1961                         gv_efullname3(sv, CvGV(cv), Nullch);
1962                     }
1963                     if (  PERLDB_GOTO
1964                           && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1965                         PUSHMARK( stack_sp );
1966                         perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1967                         stack_sp--;
1968                     }
1969                 }
1970                 RETURNOP(CvSTART(cv));
1971             }
1972         }
1973         else
1974             label = SvPV(sv,na);
1975     }
1976     else if (op->op_flags & OPf_SPECIAL) {
1977         if (! do_dump)
1978             DIE("goto must have label");
1979     }
1980     else
1981         label = cPVOP->op_pv;
1982
1983     if (label && *label) {
1984         OP *gotoprobe = 0;
1985
1986         /* find label */
1987
1988         lastgotoprobe = 0;
1989         *enterops = 0;
1990         for (ix = cxstack_ix; ix >= 0; ix--) {
1991             cx = &cxstack[ix];
1992             switch (cx->cx_type) {
1993             case CXt_EVAL:
1994                 gotoprobe = eval_root; /* XXX not good for nested eval */
1995                 break;
1996             case CXt_LOOP:
1997                 gotoprobe = cx->blk_oldcop->op_sibling;
1998                 break;
1999             case CXt_SUBST:
2000                 continue;
2001             case CXt_BLOCK:
2002                 if (ix)
2003                     gotoprobe = cx->blk_oldcop->op_sibling;
2004                 else
2005                     gotoprobe = main_root;
2006                 break;
2007             case CXt_SUB:
2008                 if (CvDEPTH(cx->blk_sub.cv)) {
2009                     gotoprobe = CvROOT(cx->blk_sub.cv);
2010                     break;
2011                 }
2012                 /* FALL THROUGH */
2013             case CXt_NULL:
2014                 DIE("Can't \"goto\" outside a block");
2015             default:
2016                 if (ix)
2017                     DIE("panic: goto");
2018                 gotoprobe = main_root;
2019                 break;
2020             }
2021             retop = dofindlabel(gotoprobe, label,
2022                                 enterops, enterops + GOTO_DEPTH);
2023             if (retop)
2024                 break;
2025             lastgotoprobe = gotoprobe;
2026         }
2027         if (!retop)
2028             DIE("Can't find label %s", label);
2029
2030         /* pop unwanted frames */
2031
2032         if (ix < cxstack_ix) {
2033             I32 oldsave;
2034
2035             if (ix < 0)
2036                 ix = 0;
2037             dounwind(ix);
2038             TOPBLOCK(cx);
2039             oldsave = scopestack[scopestack_ix];
2040             LEAVE_SCOPE(oldsave);
2041         }
2042
2043         /* push wanted frames */
2044
2045         if (*enterops && enterops[1]) {
2046             OP *oldop = op;
2047             for (ix = 1; enterops[ix]; ix++) {
2048                 op = enterops[ix];
2049                 /* Eventually we may want to stack the needed arguments
2050                  * for each op.  For now, we punt on the hard ones. */
2051                 if (op->op_type == OP_ENTERITER)
2052                     DIE("Can't \"goto\" into the middle of a foreach loop",
2053                         label);
2054                 (CALLOP->op_ppaddr)(ARGS);
2055             }
2056             op = oldop;
2057         }
2058     }
2059
2060     if (do_dump) {
2061 #ifdef VMS
2062         if (!retop) retop = main_start;
2063 #endif
2064         restartop = retop;
2065         do_undump = TRUE;
2066
2067         my_unexec();
2068
2069         restartop = 0;          /* hmm, must be GNU unexec().. */
2070         do_undump = FALSE;
2071     }
2072
2073     if (top_env->je_prev) {
2074         restartop = retop;
2075         JMPENV_JUMP(3);
2076     }
2077
2078     RETURNOP(retop);
2079 }
2080
2081 PP(pp_exit)
2082 {
2083     djSP;
2084     I32 anum;
2085
2086     if (MAXARG < 1)
2087         anum = 0;
2088     else {
2089         anum = SvIVx(POPs);
2090 #ifdef VMSISH_EXIT
2091         if (anum == 1 && VMSISH_EXIT)
2092             anum = 0;
2093 #endif
2094     }
2095     my_exit(anum);
2096     PUSHs(&sv_undef);
2097     RETURN;
2098 }
2099
2100 #ifdef NOTYET
2101 PP(pp_nswitch)
2102 {
2103     djSP;
2104     double value = SvNVx(GvSV(cCOP->cop_gv));
2105     register I32 match = I_32(value);
2106
2107     if (value < 0.0) {
2108         if (((double)match) > value)
2109             --match;            /* was fractional--truncate other way */
2110     }
2111     match -= cCOP->uop.scop.scop_offset;
2112     if (match < 0)
2113         match = 0;
2114     else if (match > cCOP->uop.scop.scop_max)
2115         match = cCOP->uop.scop.scop_max;
2116     op = cCOP->uop.scop.scop_next[match];
2117     RETURNOP(op);
2118 }
2119
2120 PP(pp_cswitch)
2121 {
2122     djSP;
2123     register I32 match;
2124
2125     if (multiline)
2126         op = op->op_next;                       /* can't assume anything */
2127     else {
2128         match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2129         match -= cCOP->uop.scop.scop_offset;
2130         if (match < 0)
2131             match = 0;
2132         else if (match > cCOP->uop.scop.scop_max)
2133             match = cCOP->uop.scop.scop_max;
2134         op = cCOP->uop.scop.scop_next[match];
2135     }
2136     RETURNOP(op);
2137 }
2138 #endif
2139
2140 /* Eval. */
2141
2142 STATIC void
2143 save_lines(AV *array, SV *sv)
2144 {
2145     register char *s = SvPVX(sv);
2146     register char *send = SvPVX(sv) + SvCUR(sv);
2147     register char *t;
2148     register I32 line = 1;
2149
2150     while (s && s < send) {
2151         SV *tmpstr = NEWSV(85,0);
2152
2153         sv_upgrade(tmpstr, SVt_PVMG);
2154         t = strchr(s, '\n');
2155         if (t)
2156             t++;
2157         else
2158             t = send;
2159
2160         sv_setpvn(tmpstr, s, t - s);
2161         av_store(array, line++, tmpstr);
2162         s = t;
2163     }
2164 }
2165
2166 STATIC OP *
2167 docatch(OP *o)
2168 {
2169     dTHR;
2170     int ret;
2171     OP *oldop = op;
2172     dJMPENV;
2173
2174     op = o;
2175 #ifdef DEBUGGING
2176     assert(CATCH_GET == TRUE);
2177     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2178 #endif
2179     JMPENV_PUSH(ret);
2180     switch (ret) {
2181     default:                            /* topmost level handles it */
2182         JMPENV_POP;
2183         op = oldop;
2184         JMPENV_JUMP(ret);
2185         /* NOTREACHED */
2186     case 3:
2187         if (!restartop) {
2188             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2189             break;
2190         }
2191         op = restartop;
2192         restartop = 0;
2193         /* FALL THROUGH */
2194     case 0:
2195         CALLRUNOPS();
2196         break;
2197     }
2198     JMPENV_POP;
2199     op = oldop;
2200     return Nullop;
2201 }
2202
2203 OP *
2204 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2205 /* sv Text to convert to OP tree. */
2206 /* startop op_free() this to undo. */
2207 /* code Short string id of the caller. */
2208 {
2209     dSP;                                /* Make POPBLOCK work. */
2210     PERL_CONTEXT *cx;
2211     SV **newsp;
2212     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2213     I32 optype;
2214     OP dummy;
2215     OP *oop = op, *rop;
2216     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2217     char *safestr;
2218
2219     ENTER;
2220     lex_start(sv);
2221     SAVETMPS;
2222     /* switch to eval mode */
2223
2224     SAVESPTR(compiling.cop_filegv);
2225     SAVEI16(compiling.cop_line);
2226     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2227     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2228     compiling.cop_line = 1;
2229     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2230        deleting the eval's FILEGV from the stash before gv_check() runs
2231        (i.e. before run-time proper). To work around the coredump that
2232        ensues, we always turn GvMULTI_on for any globals that were
2233        introduced within evals. See force_ident(). GSAR 96-10-12 */
2234     safestr = savepv(tmpbuf);
2235     SAVEDELETE(defstash, safestr, strlen(safestr));
2236     SAVEHINTS();
2237 #ifdef OP_IN_REGISTER
2238     opsave = op;
2239 #else
2240     SAVEPPTR(op);
2241 #endif
2242     hints = 0;
2243
2244     op = &dummy;
2245     op->op_type = 0;                    /* Avoid uninit warning. */
2246     op->op_flags = 0;                   /* Avoid uninit warning. */
2247     PUSHBLOCK(cx, CXt_EVAL, SP);
2248     PUSHEVAL(cx, 0, compiling.cop_filegv);
2249     rop = doeval(G_SCALAR, startop);
2250     POPBLOCK(cx,curpm);
2251     POPEVAL(cx);
2252
2253     (*startop)->op_type = OP_NULL;
2254     (*startop)->op_ppaddr = ppaddr[OP_NULL];
2255     lex_end();
2256     *avp = (AV*)SvREFCNT_inc(comppad);
2257     LEAVE;
2258 #ifdef OP_IN_REGISTER
2259     op = opsave;
2260 #endif
2261     return rop;
2262 }
2263
2264 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2265 STATIC OP *
2266 doeval(int gimme, OP** startop)
2267 {
2268     dSP;
2269     OP *saveop = op;
2270     HV *newstash;
2271     CV *caller;
2272     AV* comppadlist;
2273     I32 i;
2274
2275     in_eval = 1;
2276
2277     PUSHMARK(SP);
2278
2279     /* set up a scratch pad */
2280
2281     SAVEI32(padix);
2282     SAVESPTR(curpad);
2283     SAVESPTR(comppad);
2284     SAVESPTR(comppad_name);
2285     SAVEI32(comppad_name_fill);
2286     SAVEI32(min_intro_pending);
2287     SAVEI32(max_intro_pending);
2288
2289     caller = compcv;
2290     for (i = cxstack_ix - 1; i >= 0; i--) {
2291         PERL_CONTEXT *cx = &cxstack[i];
2292         if (cx->cx_type == CXt_EVAL)
2293             break;
2294         else if (cx->cx_type == CXt_SUB) {
2295             caller = cx->blk_sub.cv;
2296             break;
2297         }
2298     }
2299
2300     SAVESPTR(compcv);
2301     compcv = (CV*)NEWSV(1104,0);
2302     sv_upgrade((SV *)compcv, SVt_PVCV);
2303     CvUNIQUE_on(compcv);
2304 #ifdef USE_THREADS
2305     CvOWNER(compcv) = 0;
2306     New(666, CvMUTEXP(compcv), 1, perl_mutex);
2307     MUTEX_INIT(CvMUTEXP(compcv));
2308 #endif /* USE_THREADS */
2309
2310     comppad = newAV();
2311     av_push(comppad, Nullsv);
2312     curpad = AvARRAY(comppad);
2313     comppad_name = newAV();
2314     comppad_name_fill = 0;
2315     min_intro_pending = 0;
2316     padix = 0;
2317 #ifdef USE_THREADS
2318     av_store(comppad_name, 0, newSVpv("@_", 2));
2319     curpad[0] = (SV*)newAV();
2320     SvPADMY_on(curpad[0]);      /* XXX Needed? */
2321 #endif /* USE_THREADS */
2322
2323     comppadlist = newAV();
2324     AvREAL_off(comppadlist);
2325     av_store(comppadlist, 0, (SV*)comppad_name);
2326     av_store(comppadlist, 1, (SV*)comppad);
2327     CvPADLIST(compcv) = comppadlist;
2328
2329     if (!saveop || saveop->op_type != OP_REQUIRE)
2330         CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2331
2332     SAVEFREESV(compcv);
2333
2334     /* make sure we compile in the right package */
2335
2336     newstash = curcop->cop_stash;
2337     if (curstash != newstash) {
2338         SAVESPTR(curstash);
2339         curstash = newstash;
2340     }
2341     SAVESPTR(beginav);
2342     beginav = newAV();
2343     SAVEFREESV(beginav);
2344
2345     /* try to compile it */
2346
2347     eval_root = Nullop;
2348     error_count = 0;
2349     curcop = &compiling;
2350     curcop->cop_arybase = 0;
2351     SvREFCNT_dec(rs);
2352     rs = newSVpv("\n", 1);
2353     if (saveop && saveop->op_flags & OPf_SPECIAL)
2354         in_eval |= 4;
2355     else
2356         sv_setpv(ERRSV,"");
2357     if (yyparse() || error_count || !eval_root) {
2358         SV **newsp;
2359         I32 gimme;
2360         PERL_CONTEXT *cx;
2361         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2362
2363         op = saveop;
2364         if (eval_root) {
2365             op_free(eval_root);
2366             eval_root = Nullop;
2367         }
2368         SP = stack_base + POPMARK;              /* pop original mark */
2369         if (!startop) {
2370             POPBLOCK(cx,curpm);
2371             POPEVAL(cx);
2372             pop_return();
2373         }
2374         lex_end();
2375         LEAVE;
2376         if (optype == OP_REQUIRE) {
2377             char* msg = SvPVx(ERRSV, na);
2378             DIE("%s", *msg ? msg : "Compilation failed in require");
2379         } else if (startop) {
2380             char* msg = SvPVx(ERRSV, na);
2381
2382             POPBLOCK(cx,curpm);
2383             POPEVAL(cx);
2384             croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2385         }
2386         SvREFCNT_dec(rs);
2387         rs = SvREFCNT_inc(nrs);
2388 #ifdef USE_THREADS
2389         MUTEX_LOCK(&eval_mutex);
2390         eval_owner = 0;
2391         COND_SIGNAL(&eval_cond);
2392         MUTEX_UNLOCK(&eval_mutex);
2393 #endif /* USE_THREADS */
2394         RETPUSHUNDEF;
2395     }
2396     SvREFCNT_dec(rs);
2397     rs = SvREFCNT_inc(nrs);
2398     compiling.cop_line = 0;
2399     if (startop) {
2400         *startop = eval_root;
2401         SvREFCNT_dec(CvOUTSIDE(compcv));
2402         CvOUTSIDE(compcv) = Nullcv;
2403     } else
2404         SAVEFREEOP(eval_root);
2405     if (gimme & G_VOID)
2406         scalarvoid(eval_root);
2407     else if (gimme & G_ARRAY)
2408         list(eval_root);
2409     else
2410         scalar(eval_root);
2411
2412     DEBUG_x(dump_eval());
2413
2414     /* Register with debugger: */
2415     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2416         CV *cv = perl_get_cv("DB::postponed", FALSE);
2417         if (cv) {
2418             dSP;
2419             PUSHMARK(SP);
2420             XPUSHs((SV*)compiling.cop_filegv);
2421             PUTBACK;
2422             perl_call_sv((SV*)cv, G_DISCARD);
2423         }
2424     }
2425
2426     /* compiled okay, so do it */
2427
2428     CvDEPTH(compcv) = 1;
2429     SP = stack_base + POPMARK;          /* pop original mark */
2430     op = saveop;                        /* The caller may need it. */
2431 #ifdef USE_THREADS
2432     MUTEX_LOCK(&eval_mutex);
2433     eval_owner = 0;
2434     COND_SIGNAL(&eval_cond);
2435     MUTEX_UNLOCK(&eval_mutex);
2436 #endif /* USE_THREADS */
2437
2438     RETURNOP(eval_start);
2439 }
2440
2441 PP(pp_require)
2442 {
2443     djSP;
2444     register PERL_CONTEXT *cx;
2445     SV *sv;
2446     char *name;
2447     STRLEN len;
2448     char *tryname;
2449     SV *namesv = Nullsv;
2450     SV** svp;
2451     I32 gimme = G_SCALAR;
2452     PerlIO *tryrsfp = 0;
2453
2454     sv = POPs;
2455     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2456         SET_NUMERIC_STANDARD();
2457         if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2458             DIE("Perl %s required--this is only version %s, stopped",
2459                 SvPV(sv,na),patchlevel);
2460         RETPUSHYES;
2461     }
2462     name = SvPV(sv, len);
2463     if (!(name && len > 0 && *name))
2464         DIE("Null filename used");
2465     TAINT_PROPER("require");
2466     if (op->op_type == OP_REQUIRE &&
2467       (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2468       *svp != &sv_undef)
2469         RETPUSHYES;
2470
2471     /* prepare to compile file */
2472
2473     if (*name == '/' ||
2474         (*name == '.' &&
2475             (name[1] == '/' ||
2476              (name[1] == '.' && name[2] == '/')))
2477 #ifdef DOSISH
2478       || (name[0] && name[1] == ':')
2479 #endif
2480 #ifdef WIN32
2481       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2482 #endif
2483 #ifdef VMS
2484         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2485             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2486 #endif
2487     )
2488     {
2489         tryname = name;
2490         tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2491     }
2492     else {
2493         AV *ar = GvAVn(incgv);
2494         I32 i;
2495 #ifdef VMS
2496         char *unixname;
2497         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2498 #endif
2499         {
2500             namesv = NEWSV(806, 0);
2501             for (i = 0; i <= AvFILL(ar); i++) {
2502                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2503 #ifdef VMS
2504                 char *unixdir;
2505                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2506                     continue;
2507                 sv_setpv(namesv, unixdir);
2508                 sv_catpv(namesv, unixname);
2509 #else
2510                 sv_setpvf(namesv, "%s/%s", dir, name);
2511 #endif
2512                 tryname = SvPVX(namesv);
2513                 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2514                 if (tryrsfp) {
2515                     if (tryname[0] == '.' && tryname[1] == '/')
2516                         tryname += 2;
2517                     break;
2518                 }
2519             }
2520         }
2521     }
2522     SAVESPTR(compiling.cop_filegv);
2523     compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2524     SvREFCNT_dec(namesv);
2525     if (!tryrsfp) {
2526         if (op->op_type == OP_REQUIRE) {
2527             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2528             SV *dirmsgsv = NEWSV(0, 0);
2529             AV *ar = GvAVn(incgv);
2530             I32 i;
2531             if (instr(SvPVX(msg), ".h "))
2532                 sv_catpv(msg, " (change .h to .ph maybe?)");
2533             if (instr(SvPVX(msg), ".ph "))
2534                 sv_catpv(msg, " (did you run h2ph?)");
2535             sv_catpv(msg, " (@INC contains:");
2536             for (i = 0; i <= AvFILL(ar); i++) {
2537                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2538                 sv_setpvf(dirmsgsv, " %s", dir);
2539                 sv_catsv(msg, dirmsgsv);
2540             }
2541             sv_catpvn(msg, ")", 1);
2542             SvREFCNT_dec(dirmsgsv);
2543             DIE("%_", msg);
2544         }
2545
2546         RETPUSHUNDEF;
2547     }
2548
2549     /* Assume success here to prevent recursive requirement. */
2550     (void)hv_store(GvHVn(incgv), name, strlen(name),
2551         newSVsv(GvSV(compiling.cop_filegv)), 0 );
2552
2553     ENTER;
2554     SAVETMPS;
2555     lex_start(sv_2mortal(newSVpv("",0)));
2556     if (rsfp_filters){
2557         save_aptr(&rsfp_filters);
2558         rsfp_filters = NULL;
2559     }
2560
2561     rsfp = tryrsfp;
2562     name = savepv(name);
2563     SAVEFREEPV(name);
2564     SAVEHINTS();
2565     hints = 0;
2566
2567     /* switch to eval mode */
2568
2569     push_return(op->op_next);
2570     PUSHBLOCK(cx, CXt_EVAL, SP);
2571     PUSHEVAL(cx, name, compiling.cop_filegv);
2572
2573     compiling.cop_line = 0;
2574
2575     PUTBACK;
2576 #ifdef USE_THREADS
2577     MUTEX_LOCK(&eval_mutex);
2578     if (eval_owner && eval_owner != thr)
2579         while (eval_owner)
2580             COND_WAIT(&eval_cond, &eval_mutex);
2581     eval_owner = thr;
2582     MUTEX_UNLOCK(&eval_mutex);
2583 #endif /* USE_THREADS */
2584     return DOCATCH(doeval(G_SCALAR, NULL));
2585 }
2586
2587 PP(pp_dofile)
2588 {
2589     return pp_require(ARGS);
2590 }
2591
2592 PP(pp_entereval)
2593 {
2594     djSP;
2595     register PERL_CONTEXT *cx;
2596     dPOPss;
2597     I32 gimme = GIMME_V, was = sub_generation;
2598     char tmpbuf[TYPE_DIGITS(long) + 12];
2599     char *safestr;
2600     STRLEN len;
2601     OP *ret;
2602
2603     if (!SvPV(sv,len) || !len)
2604         RETPUSHUNDEF;
2605     TAINT_PROPER("eval");
2606
2607     ENTER;
2608     lex_start(sv);
2609     SAVETMPS;
2610
2611     /* switch to eval mode */
2612
2613     SAVESPTR(compiling.cop_filegv);
2614     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2615     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2616     compiling.cop_line = 1;
2617     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2618        deleting the eval's FILEGV from the stash before gv_check() runs
2619        (i.e. before run-time proper). To work around the coredump that
2620        ensues, we always turn GvMULTI_on for any globals that were
2621        introduced within evals. See force_ident(). GSAR 96-10-12 */
2622     safestr = savepv(tmpbuf);
2623     SAVEDELETE(defstash, safestr, strlen(safestr));
2624     SAVEHINTS();
2625     hints = op->op_targ;
2626
2627     push_return(op->op_next);
2628     PUSHBLOCK(cx, CXt_EVAL, SP);
2629     PUSHEVAL(cx, 0, compiling.cop_filegv);
2630
2631     /* prepare to compile string */
2632
2633     if (PERLDB_LINE && curstash != debstash)
2634         save_lines(GvAV(compiling.cop_filegv), linestr);
2635     PUTBACK;
2636 #ifdef USE_THREADS
2637     MUTEX_LOCK(&eval_mutex);
2638     if (eval_owner && eval_owner != thr)
2639         while (eval_owner)
2640             COND_WAIT(&eval_cond, &eval_mutex);
2641     eval_owner = thr;
2642     MUTEX_UNLOCK(&eval_mutex);
2643 #endif /* USE_THREADS */
2644     ret = doeval(gimme, NULL);
2645     if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2646         && ret != op->op_next) {        /* Successive compilation. */
2647         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2648     }
2649     return DOCATCH(ret);
2650 }
2651
2652 PP(pp_leaveeval)
2653 {
2654     djSP;
2655     register SV **mark;
2656     SV **newsp;
2657     PMOP *newpm;
2658     I32 gimme;
2659     register PERL_CONTEXT *cx;
2660     OP *retop;
2661     U8 save_flags = op -> op_flags;
2662     I32 optype;
2663
2664     POPBLOCK(cx,newpm);
2665     POPEVAL(cx);
2666     retop = pop_return();
2667
2668     TAINT_NOT;
2669     if (gimme == G_VOID)
2670         MARK = newsp;
2671     else if (gimme == G_SCALAR) {
2672         MARK = newsp + 1;
2673         if (MARK <= SP) {
2674             if (SvFLAGS(TOPs) & SVs_TEMP)
2675                 *MARK = TOPs;
2676             else
2677                 *MARK = sv_mortalcopy(TOPs);
2678         }
2679         else {
2680             MEXTEND(mark,0);
2681             *MARK = &sv_undef;
2682         }
2683     }
2684     else {
2685         /* in case LEAVE wipes old return values */
2686         for (mark = newsp + 1; mark <= SP; mark++) {
2687             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2688                 *mark = sv_mortalcopy(*mark);
2689                 TAINT_NOT;      /* Each item is independent */
2690             }
2691         }
2692     }
2693     curpm = newpm;      /* Don't pop $1 et al till now */
2694
2695     /*
2696      * Closures mentioned at top level of eval cannot be referenced
2697      * again, and their presence indirectly causes a memory leak.
2698      * (Note that the fact that compcv and friends are still set here
2699      * is, AFAIK, an accident.)  --Chip
2700      */
2701     if (AvFILLp(comppad_name) >= 0) {
2702         SV **svp = AvARRAY(comppad_name);
2703         I32 ix;
2704         for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2705             SV *sv = svp[ix];
2706             if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2707                 SvREFCNT_dec(sv);
2708                 svp[ix] = &sv_undef;
2709
2710                 sv = curpad[ix];
2711                 if (CvCLONE(sv)) {
2712                     SvREFCNT_dec(CvOUTSIDE(sv));
2713                     CvOUTSIDE(sv) = Nullcv;
2714                 }
2715                 else {
2716                     SvREFCNT_dec(sv);
2717                     sv = NEWSV(0,0);
2718                     SvPADTMP_on(sv);
2719                     curpad[ix] = sv;
2720                 }
2721             }
2722         }
2723     }
2724
2725 #ifdef DEBUGGING
2726     assert(CvDEPTH(compcv) == 1);
2727 #endif
2728     CvDEPTH(compcv) = 0;
2729     lex_end();
2730
2731     if (optype == OP_REQUIRE &&
2732         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2733     {
2734         /* Unassume the success we assumed earlier. */
2735         char *name = cx->blk_eval.old_name;
2736         (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2737         retop = die("%s did not return a true value", name);
2738         /* die_where() did LEAVE, or we won't be here */
2739     }
2740     else {
2741         LEAVE;
2742         if (!(save_flags & OPf_SPECIAL))
2743             sv_setpv(ERRSV,"");
2744     }
2745
2746     RETURNOP(retop);
2747 }
2748
2749 PP(pp_entertry)
2750 {
2751     djSP;
2752     register PERL_CONTEXT *cx;
2753     I32 gimme = GIMME_V;
2754
2755     ENTER;
2756     SAVETMPS;
2757
2758     push_return(cLOGOP->op_other->op_next);
2759     PUSHBLOCK(cx, CXt_EVAL, SP);
2760     PUSHEVAL(cx, 0, 0);
2761     eval_root = op;             /* Only needed so that goto works right. */
2762
2763     in_eval = 1;
2764     sv_setpv(ERRSV,"");
2765     PUTBACK;
2766     return DOCATCH(op->op_next);
2767 }
2768
2769 PP(pp_leavetry)
2770 {
2771     djSP;
2772     register SV **mark;
2773     SV **newsp;
2774     PMOP *newpm;
2775     I32 gimme;
2776     register PERL_CONTEXT *cx;
2777     I32 optype;
2778
2779     POPBLOCK(cx,newpm);
2780     POPEVAL(cx);
2781     pop_return();
2782
2783     TAINT_NOT;
2784     if (gimme == G_VOID)
2785         SP = newsp;
2786     else if (gimme == G_SCALAR) {
2787         MARK = newsp + 1;
2788         if (MARK <= SP) {
2789             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2790                 *MARK = TOPs;
2791             else
2792                 *MARK = sv_mortalcopy(TOPs);
2793         }
2794         else {
2795             MEXTEND(mark,0);
2796             *MARK = &sv_undef;
2797         }
2798         SP = MARK;
2799     }
2800     else {
2801         /* in case LEAVE wipes old return values */
2802         for (mark = newsp + 1; mark <= SP; mark++) {
2803             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2804                 *mark = sv_mortalcopy(*mark);
2805                 TAINT_NOT;      /* Each item is independent */
2806             }
2807         }
2808     }
2809     curpm = newpm;      /* Don't pop $1 et al till now */
2810
2811     LEAVE;
2812     sv_setpv(ERRSV,"");
2813     RETURN;
2814 }
2815
2816 STATIC void
2817 doparseform(SV *sv)
2818 {
2819     STRLEN len;
2820     register char *s = SvPV_force(sv, len);
2821     register char *send = s + len;
2822     register char *base;
2823     register I32 skipspaces = 0;
2824     bool noblank;
2825     bool repeat;
2826     bool postspace = FALSE;
2827     U16 *fops;
2828     register U16 *fpc;
2829     U16 *linepc;
2830     register I32 arg;
2831     bool ischop;
2832
2833     if (len == 0)
2834         croak("Null picture in formline");
2835
2836     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
2837     fpc = fops;
2838
2839     if (s < send) {
2840         linepc = fpc;
2841         *fpc++ = FF_LINEMARK;
2842         noblank = repeat = FALSE;
2843         base = s;
2844     }
2845
2846     while (s <= send) {
2847         switch (*s++) {
2848         default:
2849             skipspaces = 0;
2850             continue;
2851
2852         case '~':
2853             if (*s == '~') {
2854                 repeat = TRUE;
2855                 *s = ' ';
2856             }
2857             noblank = TRUE;
2858             s[-1] = ' ';
2859             /* FALL THROUGH */
2860         case ' ': case '\t':
2861             skipspaces++;
2862             continue;
2863
2864         case '\n': case 0:
2865             arg = s - base;
2866             skipspaces++;
2867             arg -= skipspaces;
2868             if (arg) {
2869                 if (postspace)
2870                     *fpc++ = FF_SPACE;
2871                 *fpc++ = FF_LITERAL;
2872                 *fpc++ = arg;
2873             }
2874             postspace = FALSE;
2875             if (s <= send)
2876                 skipspaces--;
2877             if (skipspaces) {
2878                 *fpc++ = FF_SKIP;
2879                 *fpc++ = skipspaces;
2880             }
2881             skipspaces = 0;
2882             if (s <= send)
2883                 *fpc++ = FF_NEWLINE;
2884             if (noblank) {
2885                 *fpc++ = FF_BLANK;
2886                 if (repeat)
2887                     arg = fpc - linepc + 1;
2888                 else
2889                     arg = 0;
2890                 *fpc++ = arg;
2891             }
2892             if (s < send) {
2893                 linepc = fpc;
2894                 *fpc++ = FF_LINEMARK;
2895                 noblank = repeat = FALSE;
2896                 base = s;
2897             }
2898             else
2899                 s++;
2900             continue;
2901
2902         case '@':
2903         case '^':
2904             ischop = s[-1] == '^';
2905
2906             if (postspace) {
2907                 *fpc++ = FF_SPACE;
2908                 postspace = FALSE;
2909             }
2910             arg = (s - base) - 1;
2911             if (arg) {
2912                 *fpc++ = FF_LITERAL;
2913                 *fpc++ = arg;
2914             }
2915
2916             base = s - 1;
2917             *fpc++ = FF_FETCH;
2918             if (*s == '*') {
2919                 s++;
2920                 *fpc++ = 0;
2921                 *fpc++ = FF_LINEGLOB;
2922             }
2923             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2924                 arg = ischop ? 512 : 0;
2925                 base = s - 1;
2926                 while (*s == '#')
2927                     s++;
2928                 if (*s == '.') {
2929                     char *f;
2930                     s++;
2931                     f = s;
2932                     while (*s == '#')
2933                         s++;
2934                     arg |= 256 + (s - f);
2935                 }
2936                 *fpc++ = s - base;              /* fieldsize for FETCH */
2937                 *fpc++ = FF_DECIMAL;
2938                 *fpc++ = arg;
2939             }
2940             else {
2941                 I32 prespace = 0;
2942                 bool ismore = FALSE;
2943
2944                 if (*s == '>') {
2945                     while (*++s == '>') ;
2946                     prespace = FF_SPACE;
2947                 }
2948                 else if (*s == '|') {
2949                     while (*++s == '|') ;
2950                     prespace = FF_HALFSPACE;
2951                     postspace = TRUE;
2952                 }
2953                 else {
2954                     if (*s == '<')
2955                         while (*++s == '<') ;
2956                     postspace = TRUE;
2957                 }
2958                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2959                     s += 3;
2960                     ismore = TRUE;
2961                 }
2962                 *fpc++ = s - base;              /* fieldsize for FETCH */
2963
2964                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2965
2966                 if (prespace)
2967                     *fpc++ = prespace;
2968                 *fpc++ = FF_ITEM;
2969                 if (ismore)
2970                     *fpc++ = FF_MORE;
2971                 if (ischop)
2972                     *fpc++ = FF_CHOP;
2973             }
2974             base = s;
2975             skipspaces = 0;
2976             continue;
2977         }
2978     }
2979     *fpc++ = FF_END;
2980
2981     arg = fpc - fops;
2982     { /* need to jump to the next word */
2983         int z;
2984         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2985         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2986         s = SvPVX(sv) + SvCUR(sv) + z;
2987     }
2988     Copy(fops, s, arg, U16);
2989     Safefree(fops);
2990     sv_magic(sv, Nullsv, 'f', Nullch, 0);
2991     SvCOMPILED_on(sv);
2992 }
2993
2994 /*
2995  * The rest of this file was derived from source code contributed
2996  * by Tom Horsley.
2997  *
2998  * NOTE: this code was derived from Tom Horsley's qsort replacement
2999  * and should not be confused with the original code.
3000  */
3001
3002 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3003
3004    Permission granted to distribute under the same terms as perl which are
3005    (briefly):
3006
3007     This program is free software; you can redistribute it and/or modify
3008     it under the terms of either:
3009
3010         a) the GNU General Public License as published by the Free
3011         Software Foundation; either version 1, or (at your option) any
3012         later version, or
3013
3014         b) the "Artistic License" which comes with this Kit.
3015
3016    Details on the perl license can be found in the perl source code which
3017    may be located via the www.perl.com web page.
3018
3019    This is the most wonderfulest possible qsort I can come up with (and
3020    still be mostly portable) My (limited) tests indicate it consistently
3021    does about 20% fewer calls to compare than does the qsort in the Visual
3022    C++ library, other vendors may vary.
3023
3024    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3025    others I invented myself (or more likely re-invented since they seemed
3026    pretty obvious once I watched the algorithm operate for a while).
3027
3028    Most of this code was written while watching the Marlins sweep the Giants
3029    in the 1997 National League Playoffs - no Braves fans allowed to use this
3030    code (just kidding :-).
3031
3032    I realize that if I wanted to be true to the perl tradition, the only
3033    comment in this file would be something like:
3034
3035    ...they shuffled back towards the rear of the line. 'No, not at the
3036    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3037
3038    However, I really needed to violate that tradition just so I could keep
3039    track of what happens myself, not to mention some poor fool trying to
3040    understand this years from now :-).
3041 */
3042
3043 /* ********************************************************** Configuration */
3044
3045 #ifndef QSORT_ORDER_GUESS
3046 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3047 #endif
3048
3049 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3050    future processing - a good max upper bound is log base 2 of memory size
3051    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3052    safely be smaller than that since the program is taking up some space and
3053    most operating systems only let you grab some subset of contiguous
3054    memory (not to mention that you are normally sorting data larger than
3055    1 byte element size :-).
3056 */
3057 #ifndef QSORT_MAX_STACK
3058 #define QSORT_MAX_STACK 32
3059 #endif
3060
3061 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3062    Anything bigger and we use qsort. If you make this too small, the qsort
3063    will probably break (or become less efficient), because it doesn't expect
3064    the middle element of a partition to be the same as the right or left -
3065    you have been warned).
3066 */
3067 #ifndef QSORT_BREAK_EVEN
3068 #define QSORT_BREAK_EVEN 6
3069 #endif
3070
3071 /* ************************************************************* Data Types */
3072
3073 /* hold left and right index values of a partition waiting to be sorted (the
3074    partition includes both left and right - right is NOT one past the end or
3075    anything like that).
3076 */
3077 struct partition_stack_entry {
3078    int left;
3079    int right;
3080 #ifdef QSORT_ORDER_GUESS
3081    int qsort_break_even;
3082 #endif
3083 };
3084
3085 /* ******************************************************* Shorthand Macros */
3086
3087 /* Note that these macros will be used from inside the qsort function where
3088    we happen to know that the variable 'elt_size' contains the size of an
3089    array element and the variable 'temp' points to enough space to hold a
3090    temp element and the variable 'array' points to the array being sorted
3091    and 'compare' is the pointer to the compare routine.
3092
3093    Also note that there are very many highly architecture specific ways
3094    these might be sped up, but this is simply the most generally portable
3095    code I could think of.
3096 */
3097
3098 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3099 */
3100 #ifdef PERL_OBJECT
3101 #define qsort_cmp(elt1, elt2) \
3102    ((this->*compare)(array[elt1], array[elt2]))
3103 #else
3104 #define qsort_cmp(elt1, elt2) \
3105    ((*compare)(array[elt1], array[elt2]))
3106 #endif
3107
3108 #ifdef QSORT_ORDER_GUESS
3109 #define QSORT_NOTICE_SWAP swapped++;
3110 #else
3111 #define QSORT_NOTICE_SWAP
3112 #endif
3113
3114 /* swaps contents of array elements elt1, elt2.
3115 */
3116 #define qsort_swap(elt1, elt2) \
3117    STMT_START { \
3118       QSORT_NOTICE_SWAP \
3119       temp = array[elt1]; \
3120       array[elt1] = array[elt2]; \
3121       array[elt2] = temp; \
3122    } STMT_END
3123
3124 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3125    elt3 and elt3 gets elt1.
3126 */
3127 #define qsort_rotate(elt1, elt2, elt3) \
3128    STMT_START { \
3129       QSORT_NOTICE_SWAP \
3130       temp = array[elt1]; \
3131       array[elt1] = array[elt2]; \
3132       array[elt2] = array[elt3]; \
3133       array[elt3] = temp; \
3134    } STMT_END
3135
3136 /* ************************************************************ Debug stuff */
3137
3138 #ifdef QSORT_DEBUG
3139
3140 static void
3141 break_here()
3142 {
3143    return; /* good place to set a breakpoint */
3144 }
3145
3146 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3147
3148 static void
3149 doqsort_all_asserts(
3150    void * array,
3151    size_t num_elts,
3152    size_t elt_size,
3153    int (*compare)(const void * elt1, const void * elt2),
3154    int pc_left, int pc_right, int u_left, int u_right)
3155 {
3156    int i;
3157
3158    qsort_assert(pc_left <= pc_right);
3159    qsort_assert(u_right < pc_left);
3160    qsort_assert(pc_right < u_left);
3161    for (i = u_right + 1; i < pc_left; ++i) {
3162       qsort_assert(qsort_cmp(i, pc_left) < 0);
3163    }
3164    for (i = pc_left; i < pc_right; ++i) {
3165       qsort_assert(qsort_cmp(i, pc_right) == 0);
3166    }
3167    for (i = pc_right + 1; i < u_left; ++i) {
3168       qsort_assert(qsort_cmp(pc_right, i) < 0);
3169    }
3170 }
3171
3172 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3173    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3174                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3175
3176 #else
3177
3178 #define qsort_assert(t) ((void)0)
3179
3180 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3181
3182 #endif
3183
3184 /* ****************************************************************** qsort */
3185
3186 void
3187 #ifdef PERL_OBJECT
3188 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3189 #else
3190 qsortsv(
3191    SV ** array,
3192    size_t num_elts,
3193    I32 (*compare)(SV *a, SV *b))
3194 #endif
3195 {
3196    register SV * temp;
3197
3198    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3199    int next_stack_entry = 0;
3200
3201    int part_left;
3202    int part_right;
3203 #ifdef QSORT_ORDER_GUESS
3204    int qsort_break_even;
3205    int swapped;
3206 #endif
3207
3208    /* Make sure we actually have work to do.
3209    */
3210    if (num_elts <= 1) {
3211       return;
3212    }
3213
3214    /* Setup the initial partition definition and fall into the sorting loop
3215    */
3216    part_left = 0;
3217    part_right = (int)(num_elts - 1);
3218 #ifdef QSORT_ORDER_GUESS
3219    qsort_break_even = QSORT_BREAK_EVEN;
3220 #else
3221 #define qsort_break_even QSORT_BREAK_EVEN
3222 #endif
3223    for ( ; ; ) {
3224       if ((part_right - part_left) >= qsort_break_even) {
3225          /* OK, this is gonna get hairy, so lets try to document all the
3226             concepts and abbreviations and variables and what they keep
3227             track of:
3228
3229             pc: pivot chunk - the set of array elements we accumulate in the
3230                 middle of the partition, all equal in value to the original
3231                 pivot element selected. The pc is defined by:
3232
3233                 pc_left - the leftmost array index of the pc
3234                 pc_right - the rightmost array index of the pc
3235
3236                 we start with pc_left == pc_right and only one element
3237                 in the pivot chunk (but it can grow during the scan).
3238
3239             u:  uncompared elements - the set of elements in the partition
3240                 we have not yet compared to the pivot value. There are two
3241                 uncompared sets during the scan - one to the left of the pc
3242                 and one to the right.
3243
3244                 u_right - the rightmost index of the left side's uncompared set
3245                 u_left - the leftmost index of the right side's uncompared set
3246
3247                 The leftmost index of the left sides's uncompared set
3248                 doesn't need its own variable because it is always defined
3249                 by the leftmost edge of the whole partition (part_left). The
3250                 same goes for the rightmost edge of the right partition
3251                 (part_right).
3252
3253                 We know there are no uncompared elements on the left once we
3254                 get u_right < part_left and no uncompared elements on the
3255                 right once u_left > part_right. When both these conditions
3256                 are met, we have completed the scan of the partition.
3257
3258                 Any elements which are between the pivot chunk and the
3259                 uncompared elements should be less than the pivot value on
3260                 the left side and greater than the pivot value on the right
3261                 side (in fact, the goal of the whole algorithm is to arrange
3262                 for that to be true and make the groups of less-than and
3263                 greater-then elements into new partitions to sort again).
3264
3265             As you marvel at the complexity of the code and wonder why it
3266             has to be so confusing. Consider some of the things this level
3267             of confusion brings:
3268
3269             Once I do a compare, I squeeze every ounce of juice out of it. I
3270             never do compare calls I don't have to do, and I certainly never
3271             do redundant calls.
3272
3273             I also never swap any elements unless I can prove there is a
3274             good reason. Many sort algorithms will swap a known value with
3275             an uncompared value just to get things in the right place (or
3276             avoid complexity :-), but that uncompared value, once it gets
3277             compared, may then have to be swapped again. A lot of the
3278             complexity of this code is due to the fact that it never swaps
3279             anything except compared values, and it only swaps them when the
3280             compare shows they are out of position.
3281          */
3282          int pc_left, pc_right;
3283          int u_right, u_left;
3284
3285          int s;
3286
3287          pc_left = ((part_left + part_right) / 2);
3288          pc_right = pc_left;
3289          u_right = pc_left - 1;
3290          u_left = pc_right + 1;
3291
3292          /* Qsort works best when the pivot value is also the median value
3293             in the partition (unfortunately you can't find the median value
3294             without first sorting :-), so to give the algorithm a helping
3295             hand, we pick 3 elements and sort them and use the median value
3296             of that tiny set as the pivot value.
3297
3298             Some versions of qsort like to use the left middle and right as
3299             the 3 elements to sort so they can insure the ends of the
3300             partition will contain values which will stop the scan in the
3301             compare loop, but when you have to call an arbitrarily complex
3302             routine to do a compare, its really better to just keep track of
3303             array index values to know when you hit the edge of the
3304             partition and avoid the extra compare. An even better reason to
3305             avoid using a compare call is the fact that you can drop off the
3306             edge of the array if someone foolishly provides you with an
3307             unstable compare function that doesn't always provide consistent
3308             results.
3309
3310             So, since it is simpler for us to compare the three adjacent
3311             elements in the middle of the partition, those are the ones we
3312             pick here (conveniently pointed at by u_right, pc_left, and
3313             u_left). The values of the left, center, and right elements
3314             are refered to as l c and r in the following comments.
3315          */
3316
3317 #ifdef QSORT_ORDER_GUESS
3318          swapped = 0;
3319 #endif
3320          s = qsort_cmp(u_right, pc_left);
3321          if (s < 0) {
3322             /* l < c */
3323             s = qsort_cmp(pc_left, u_left);
3324             /* if l < c, c < r - already in order - nothing to do */
3325             if (s == 0) {
3326                /* l < c, c == r - already in order, pc grows */
3327                ++pc_right;
3328                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3329             } else if (s > 0) {
3330                /* l < c, c > r - need to know more */
3331                s = qsort_cmp(u_right, u_left);
3332                if (s < 0) {
3333                   /* l < c, c > r, l < r - swap c & r to get ordered */
3334                   qsort_swap(pc_left, u_left);
3335                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3336                } else if (s == 0) {
3337                   /* l < c, c > r, l == r - swap c&r, grow pc */
3338                   qsort_swap(pc_left, u_left);
3339                   --pc_left;
3340                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3341                } else {
3342                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3343                   qsort_rotate(pc_left, u_right, u_left);
3344                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3345                }
3346             }
3347          } else if (s == 0) {
3348             /* l == c */
3349             s = qsort_cmp(pc_left, u_left);
3350             if (s < 0) {
3351                /* l == c, c < r - already in order, grow pc */
3352                --pc_left;
3353                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3354             } else if (s == 0) {
3355                /* l == c, c == r - already in order, grow pc both ways */
3356                --pc_left;
3357                ++pc_right;
3358                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3359             } else {
3360                /* l == c, c > r - swap l & r, grow pc */
3361                qsort_swap(u_right, u_left);
3362                ++pc_right;
3363                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3364             }
3365          } else {
3366             /* l > c */
3367             s = qsort_cmp(pc_left, u_left);
3368             if (s < 0) {
3369                /* l > c, c < r - need to know more */
3370                s = qsort_cmp(u_right, u_left);
3371                if (s < 0) {
3372                   /* l > c, c < r, l < r - swap l & c to get ordered */
3373                   qsort_swap(u_right, pc_left);
3374                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3375                } else if (s == 0) {
3376                   /* l > c, c < r, l == r - swap l & c, grow pc */
3377                   qsort_swap(u_right, pc_left);
3378                   ++pc_right;
3379                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3380                } else {
3381                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3382                   qsort_rotate(u_right, pc_left, u_left);
3383                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3384                }
3385             } else if (s == 0) {
3386                /* l > c, c == r - swap ends, grow pc */
3387                qsort_swap(u_right, u_left);
3388                --pc_left;
3389                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3390             } else {
3391                /* l > c, c > r - swap ends to get in order */
3392                qsort_swap(u_right, u_left);
3393                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3394             }
3395          }
3396          /* We now know the 3 middle elements have been compared and
3397             arranged in the desired order, so we can shrink the uncompared
3398             sets on both sides
3399          */
3400          --u_right;
3401          ++u_left;
3402          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3403
3404          /* The above massive nested if was the simple part :-). We now have
3405             the middle 3 elements ordered and we need to scan through the
3406             uncompared sets on either side, swapping elements that are on
3407             the wrong side or simply shuffling equal elements around to get
3408             all equal elements into the pivot chunk.
3409          */
3410
3411          for ( ; ; ) {
3412             int still_work_on_left;
3413             int still_work_on_right;
3414
3415             /* Scan the uncompared values on the left. If I find a value
3416                equal to the pivot value, move it over so it is adjacent to
3417                the pivot chunk and expand the pivot chunk. If I find a value
3418                less than the pivot value, then just leave it - its already
3419                on the correct side of the partition. If I find a greater
3420                value, then stop the scan.
3421             */
3422             while (still_work_on_left = (u_right >= part_left)) {
3423                s = qsort_cmp(u_right, pc_left);
3424                if (s < 0) {
3425                   --u_right;
3426                } else if (s == 0) {
3427                   --pc_left;
3428                   if (pc_left != u_right) {
3429                      qsort_swap(u_right, pc_left);
3430                   }
3431                   --u_right;
3432                } else {
3433                   break;
3434                }
3435                qsort_assert(u_right < pc_left);
3436                qsort_assert(pc_left <= pc_right);
3437                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3438                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3439             }
3440
3441             /* Do a mirror image scan of uncompared values on the right
3442             */
3443             while (still_work_on_right = (u_left <= part_right)) {
3444                s = qsort_cmp(pc_right, u_left);
3445                if (s < 0) {
3446                   ++u_left;
3447                } else if (s == 0) {
3448                   ++pc_right;
3449                   if (pc_right != u_left) {
3450                      qsort_swap(pc_right, u_left);
3451                   }
3452                   ++u_left;
3453                } else {
3454                   break;
3455                }
3456                qsort_assert(u_left > pc_right);
3457                qsort_assert(pc_left <= pc_right);
3458                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3459                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3460             }
3461
3462             if (still_work_on_left) {
3463                /* I know I have a value on the left side which needs to be
3464                   on the right side, but I need to know more to decide
3465                   exactly the best thing to do with it.
3466                */
3467                if (still_work_on_right) {
3468                   /* I know I have values on both side which are out of
3469                      position. This is a big win because I kill two birds
3470                      with one swap (so to speak). I can advance the
3471                      uncompared pointers on both sides after swapping both
3472                      of them into the right place.
3473                   */
3474                   qsort_swap(u_right, u_left);
3475                   --u_right;
3476                   ++u_left;
3477                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3478                } else {
3479                   /* I have an out of position value on the left, but the
3480                      right is fully scanned, so I "slide" the pivot chunk
3481                      and any less-than values left one to make room for the
3482                      greater value over on the right. If the out of position
3483                      value is immediately adjacent to the pivot chunk (there
3484                      are no less-than values), I can do that with a swap,
3485                      otherwise, I have to rotate one of the less than values
3486                      into the former position of the out of position value
3487                      and the right end of the pivot chunk into the left end
3488                      (got all that?).
3489                   */
3490                   --pc_left;
3491                   if (pc_left == u_right) {
3492                      qsort_swap(u_right, pc_right);
3493                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3494                   } else {
3495                      qsort_rotate(u_right, pc_left, pc_right);
3496                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3497                   }
3498                   --pc_right;
3499                   --u_right;
3500                }
3501             } else if (still_work_on_right) {
3502                /* Mirror image of complex case above: I have an out of
3503                   position value on the right, but the left is fully
3504                   scanned, so I need to shuffle things around to make room
3505                   for the right value on the left.
3506                */
3507                ++pc_right;
3508                if (pc_right == u_left) {
3509                   qsort_swap(u_left, pc_left);
3510                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3511                } else {
3512                   qsort_rotate(pc_right, pc_left, u_left);
3513                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3514                }
3515                ++pc_left;
3516                ++u_left;
3517             } else {
3518                /* No more scanning required on either side of partition,
3519                   break out of loop and figure out next set of partitions
3520                */
3521                break;
3522             }
3523          }
3524
3525          /* The elements in the pivot chunk are now in the right place. They
3526             will never move or be compared again. All I have to do is decide
3527             what to do with the stuff to the left and right of the pivot
3528             chunk.
3529
3530             Notes on the QSORT_ORDER_GUESS ifdef code:
3531
3532             1. If I just built these partitions without swapping any (or
3533                very many) elements, there is a chance that the elements are
3534                already ordered properly (being properly ordered will
3535                certainly result in no swapping, but the converse can't be
3536                proved :-).
3537
3538             2. A (properly written) insertion sort will run faster on
3539                already ordered data than qsort will.
3540
3541             3. Perhaps there is some way to make a good guess about
3542                switching to an insertion sort earlier than partition size 6
3543                (for instance - we could save the partition size on the stack
3544                and increase the size each time we find we didn't swap, thus
3545                switching to insertion sort earlier for partitions with a
3546                history of not swapping).
3547
3548             4. Naturally, if I just switch right away, it will make
3549                artificial benchmarks with pure ascending (or descending)
3550                data look really good, but is that a good reason in general?
3551                Hard to say...
3552          */
3553
3554 #ifdef QSORT_ORDER_GUESS
3555          if (swapped < 3) {
3556 #if QSORT_ORDER_GUESS == 1
3557             qsort_break_even = (part_right - part_left) + 1;
3558 #endif
3559 #if QSORT_ORDER_GUESS == 2
3560             qsort_break_even *= 2;
3561 #endif
3562 #if QSORT_ORDER_GUESS == 3
3563             int prev_break = qsort_break_even;
3564             qsort_break_even *= qsort_break_even;
3565             if (qsort_break_even < prev_break) {
3566                qsort_break_even = (part_right - part_left) + 1;
3567             }
3568 #endif
3569          } else {
3570             qsort_break_even = QSORT_BREAK_EVEN;
3571          }
3572 #endif
3573
3574          if (part_left < pc_left) {
3575             /* There are elements on the left which need more processing.
3576                Check the right as well before deciding what to do.
3577             */
3578             if (pc_right < part_right) {
3579                /* We have two partitions to be sorted. Stack the biggest one
3580                   and process the smallest one on the next iteration. This
3581                   minimizes the stack height by insuring that any additional
3582                   stack entries must come from the smallest partition which
3583                   (because it is smallest) will have the fewest
3584                   opportunities to generate additional stack entries.
3585                */
3586                if ((part_right - pc_right) > (pc_left - part_left)) {
3587                   /* stack the right partition, process the left */
3588                   partition_stack[next_stack_entry].left = pc_right + 1;
3589                   partition_stack[next_stack_entry].right = part_right;
3590 #ifdef QSORT_ORDER_GUESS
3591                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3592 #endif
3593                   part_right = pc_left - 1;
3594                } else {
3595                   /* stack the left partition, process the right */
3596                   partition_stack[next_stack_entry].left = part_left;
3597                   partition_stack[next_stack_entry].right = pc_left - 1;
3598 #ifdef QSORT_ORDER_GUESS
3599                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3600 #endif
3601                   part_left = pc_right + 1;
3602                }
3603                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3604                ++next_stack_entry;
3605             } else {
3606                /* The elements on the left are the only remaining elements
3607                   that need sorting, arrange for them to be processed as the
3608                   next partition.
3609                */
3610                part_right = pc_left - 1;
3611             }
3612          } else if (pc_right < part_right) {
3613             /* There is only one chunk on the right to be sorted, make it
3614                the new partition and loop back around.
3615             */
3616             part_left = pc_right + 1;
3617          } else {
3618             /* This whole partition wound up in the pivot chunk, so
3619                we need to get a new partition off the stack.
3620             */
3621             if (next_stack_entry == 0) {
3622                /* the stack is empty - we are done */
3623                break;
3624             }
3625             --next_stack_entry;
3626             part_left = partition_stack[next_stack_entry].left;
3627             part_right = partition_stack[next_stack_entry].right;
3628 #ifdef QSORT_ORDER_GUESS
3629             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3630 #endif
3631          }
3632       } else {
3633          /* This partition is too small to fool with qsort complexity, just
3634             do an ordinary insertion sort to minimize overhead.
3635          */
3636          int i;
3637          /* Assume 1st element is in right place already, and start checking
3638             at 2nd element to see where it should be inserted.
3639          */
3640          for (i = part_left + 1; i <= part_right; ++i) {
3641             int j;
3642             /* Scan (backwards - just in case 'i' is already in right place)
3643                through the elements already sorted to see if the ith element
3644                belongs ahead of one of them.
3645             */
3646             for (j = i - 1; j >= part_left; --j) {
3647                if (qsort_cmp(i, j) >= 0) {
3648                   /* i belongs right after j
3649                   */
3650                   break;
3651                }
3652             }
3653             ++j;
3654             if (j != i) {
3655                /* Looks like we really need to move some things
3656                */
3657                int k;
3658                temp = array[i];
3659                for (k = i - 1; k >= j; --k)
3660                   array[k + 1] = array[k];
3661                array[j] = temp;
3662             }
3663          }
3664
3665          /* That partition is now sorted, grab the next one, or get out
3666             of the loop if there aren't any more.
3667          */
3668
3669          if (next_stack_entry == 0) {
3670             /* the stack is empty - we are done */
3671             break;
3672          }
3673          --next_stack_entry;
3674          part_left = partition_stack[next_stack_entry].left;
3675          part_right = partition_stack[next_stack_entry].right;
3676 #ifdef QSORT_ORDER_GUESS
3677          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3678 #endif
3679       }
3680    }
3681
3682    /* Believe it or not, the array is sorted at this point! */
3683 }