pp_ctl.c

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