pp_ctl.c

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