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