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