pp_ctl.c

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