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