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, STRLEN msglen)
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
1336                 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1337                 if (svp) {
1338                     if (!SvIOK(*svp)) {
1339                         static char prefix[] = "\t(in cleanup) ";
1340                         SV *err = ERRSV;
1341                         sv_upgrade(*svp, SVt_IV);
1342                         (void)SvIOK_only(*svp);
1343                         if (!SvPOK(err))
1344                             sv_setpv(err,"");
1345                         SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1346                         sv_catpvn(err, prefix, sizeof(prefix)-1);
1347                         sv_catpvn(err, message, msglen);
1348                         if (ckWARN(WARN_UNSAFE)) {
1349                             STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1350                             warner(WARN_UNSAFE, SvPVX(err)+start);
1351                         }
1352                     }
1353                     sv_inc(*svp);
1354                 }
1355             }
1356             else
1357                 sv_setpvn(ERRSV, message, msglen);
1358         }
1359         else
1360             message = SvPVx(ERRSV, msglen);
1361
1362         while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1363             dounwind(-1);
1364             POPSTACK;
1365         }
1366
1367         if (cxix >= 0) {
1368             I32 optype;
1369
1370             if (cxix < cxstack_ix)
1371                 dounwind(cxix);
1372
1373             POPBLOCK(cx,PL_curpm);
1374             if (CxTYPE(cx) != CXt_EVAL) {
1375                 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1376                 PerlIO_write(PerlIO_stderr(), message, msglen);
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, msglen);
1396     {
1397 #ifdef USE_SFIO
1398         /* SFIO can really mess with your errno */
1399         int e = errno;
1400 #endif
1401         PerlIO_write(PerlIO_stderr(), message, msglen);
1402         (void)PerlIO_flush(PerlIO_stderr());
1403 #ifdef USE_SFIO
1404         errno = e;
1405 #endif
1406     }
1407     my_failure_exit();
1408     /* NOTREACHED */
1409     return 0;
1410 }
1411
1412 PP(pp_xor)
1413 {
1414     djSP; dPOPTOPssrl;
1415     if (SvTRUE(left) != SvTRUE(right))
1416         RETSETYES;
1417     else
1418         RETSETNO;
1419 }
1420
1421 PP(pp_andassign)
1422 {
1423     djSP;
1424     if (!SvTRUE(TOPs))
1425         RETURN;
1426     else
1427         RETURNOP(cLOGOP->op_other);
1428 }
1429
1430 PP(pp_orassign)
1431 {
1432     djSP;
1433     if (SvTRUE(TOPs))
1434         RETURN;
1435     else
1436         RETURNOP(cLOGOP->op_other);
1437 }
1438
1439 PP(pp_caller)
1440 {
1441     djSP;
1442     register I32 cxix = dopoptosub(cxstack_ix);
1443     register PERL_CONTEXT *cx;
1444     register PERL_CONTEXT *ccstack = cxstack;
1445     PERL_SI *top_si = PL_curstackinfo;
1446     I32 dbcxix;
1447     I32 gimme;
1448     HV *hv;
1449     SV *sv;
1450     I32 count = 0;
1451
1452     if (MAXARG)
1453         count = POPi;
1454     EXTEND(SP, 6);
1455     for (;;) {
1456         /* we may be in a higher stacklevel, so dig down deeper */
1457         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1458             top_si = top_si->si_prev;
1459             ccstack = top_si->si_cxstack;
1460             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1461         }
1462         if (cxix < 0) {
1463             if (GIMME != G_ARRAY)
1464                 RETPUSHUNDEF;
1465             RETURN;
1466         }
1467         if (PL_DBsub && cxix >= 0 &&
1468                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1469             count++;
1470         if (!count--)
1471             break;
1472         cxix = dopoptosub_at(ccstack, cxix - 1);
1473     }
1474
1475     cx = &ccstack[cxix];
1476     if (CxTYPE(cx) == CXt_SUB) {
1477         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1478         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1479            field below is defined for any cx. */
1480         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1481             cx = &ccstack[dbcxix];
1482     }
1483
1484     if (GIMME != G_ARRAY) {
1485         hv = cx->blk_oldcop->cop_stash;
1486         if (!hv)
1487             PUSHs(&PL_sv_undef);
1488         else {
1489             dTARGET;
1490             sv_setpv(TARG, HvNAME(hv));
1491             PUSHs(TARG);
1492         }
1493         RETURN;
1494     }
1495
1496     hv = cx->blk_oldcop->cop_stash;
1497     if (!hv)
1498         PUSHs(&PL_sv_undef);
1499     else
1500         PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1501     PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1502                               SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1503     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1504     if (!MAXARG)
1505         RETURN;
1506     if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1507         sv = NEWSV(49, 0);
1508         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1509         PUSHs(sv_2mortal(sv));
1510         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1511     }
1512     else {
1513         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1514         PUSHs(sv_2mortal(newSViv(0)));
1515     }
1516     gimme = (I32)cx->blk_gimme;
1517     if (gimme == G_VOID)
1518         PUSHs(&PL_sv_undef);
1519     else
1520         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1521     if (CxTYPE(cx) == CXt_EVAL) {
1522         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1523             PUSHs(cx->blk_eval.cur_text);
1524             PUSHs(&PL_sv_no);
1525         }
1526         else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1527             /* Require, put the name. */
1528             PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1529             PUSHs(&PL_sv_yes);
1530         }
1531     }
1532     else if (CxTYPE(cx) == CXt_SUB &&
1533             cx->blk_sub.hasargs &&
1534             PL_curcop->cop_stash == PL_debstash)
1535     {
1536         AV *ary = cx->blk_sub.argarray;
1537         int off = AvARRAY(ary) - AvALLOC(ary);
1538
1539         if (!PL_dbargs) {
1540             GV* tmpgv;
1541             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1542                                 SVt_PVAV)));
1543             GvMULTI_on(tmpgv);
1544             AvREAL_off(PL_dbargs);              /* XXX Should be REIFY */
1545         }
1546
1547         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1548             av_extend(PL_dbargs, AvFILLp(ary) + off);
1549         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1550         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1551     }
1552     RETURN;
1553 }
1554
1555 STATIC I32
1556 sortcv(SV *a, SV *b)
1557 {
1558     dTHR;
1559     I32 oldsaveix = PL_savestack_ix;
1560     I32 oldscopeix = PL_scopestack_ix;
1561     I32 result;
1562     GvSV(PL_firstgv) = a;
1563     GvSV(PL_secondgv) = b;
1564     PL_stack_sp = PL_stack_base;
1565     PL_op = PL_sortcop;
1566     CALLRUNOPS();
1567     if (PL_stack_sp != PL_stack_base + 1)
1568         croak("Sort subroutine didn't return single value");
1569     if (!SvNIOKp(*PL_stack_sp))
1570         croak("Sort subroutine didn't return a numeric value");
1571     result = SvIV(*PL_stack_sp);
1572     while (PL_scopestack_ix > oldscopeix) {
1573         LEAVE;
1574     }
1575     leave_scope(oldsaveix);
1576     return result;
1577 }
1578
1579 PP(pp_reset)
1580 {
1581     djSP;
1582     char *tmps;
1583     STRLEN n_a;
1584
1585     if (MAXARG < 1)
1586         tmps = "";
1587     else
1588         tmps = POPpx;
1589     sv_reset(tmps, PL_curcop->cop_stash);
1590     PUSHs(&PL_sv_yes);
1591     RETURN;
1592 }
1593
1594 PP(pp_lineseq)
1595 {
1596     return NORMAL;
1597 }
1598
1599 PP(pp_dbstate)
1600 {
1601     PL_curcop = (COP*)PL_op;
1602     TAINT_NOT;          /* Each statement is presumed innocent */
1603     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1604     FREETMPS;
1605
1606     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1607     {
1608         djSP;
1609         register CV *cv;
1610         register PERL_CONTEXT *cx;
1611         I32 gimme = G_ARRAY;
1612         I32 hasargs;
1613         GV *gv;
1614
1615         gv = PL_DBgv;
1616         cv = GvCV(gv);
1617         if (!cv)
1618             DIE("No DB::DB routine defined");
1619
1620         if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1621             return NORMAL;
1622
1623         ENTER;
1624         SAVETMPS;
1625
1626         SAVEI32(PL_debug);
1627         SAVESTACK_POS();
1628         PL_debug = 0;
1629         hasargs = 0;
1630         SPAGAIN;
1631
1632         push_return(PL_op->op_next);
1633         PUSHBLOCK(cx, CXt_SUB, SP);
1634         PUSHSUB(cx);
1635         CvDEPTH(cv)++;
1636         (void)SvREFCNT_inc(cv);
1637         SAVESPTR(PL_curpad);
1638         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1639         RETURNOP(CvSTART(cv));
1640     }
1641     else
1642         return NORMAL;
1643 }
1644
1645 PP(pp_scope)
1646 {
1647     return NORMAL;
1648 }
1649
1650 PP(pp_enteriter)
1651 {
1652     djSP; dMARK;
1653     register PERL_CONTEXT *cx;
1654     I32 gimme = GIMME_V;
1655     SV **svp;
1656
1657     ENTER;
1658     SAVETMPS;
1659
1660 #ifdef USE_THREADS
1661     if (PL_op->op_flags & OPf_SPECIAL) {
1662         dTHR;
1663         svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1664         SAVEGENERICSV(*svp);
1665         *svp = NEWSV(0,0);
1666     }
1667     else
1668 #endif /* USE_THREADS */
1669     if (PL_op->op_targ) {
1670         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1671         SAVESPTR(*svp);
1672     }
1673     else {
1674         svp = &GvSV((GV*)POPs);                 /* symbol table variable */
1675         SAVEGENERICSV(*svp);
1676         *svp = NEWSV(0,0);
1677     }
1678
1679     ENTER;
1680
1681     PUSHBLOCK(cx, CXt_LOOP, SP);
1682     PUSHLOOP(cx, svp, MARK);
1683     if (PL_op->op_flags & OPf_STACKED) {
1684         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1685         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1686             dPOPss;
1687             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1688                 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1689                  if (SvNV(sv) < IV_MIN ||
1690                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1691                      croak("Range iterator outside integer range");
1692                  cx->blk_loop.iterix = SvIV(sv);
1693                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1694             }
1695             else
1696                 cx->blk_loop.iterlval = newSVsv(sv);
1697         }
1698     }
1699     else {
1700         cx->blk_loop.iterary = PL_curstack;
1701         AvFILLp(PL_curstack) = SP - PL_stack_base;
1702         cx->blk_loop.iterix = MARK - PL_stack_base;
1703     }
1704
1705     RETURN;
1706 }
1707
1708 PP(pp_enterloop)
1709 {
1710     djSP;
1711     register PERL_CONTEXT *cx;
1712     I32 gimme = GIMME_V;
1713
1714     ENTER;
1715     SAVETMPS;
1716     ENTER;
1717
1718     PUSHBLOCK(cx, CXt_LOOP, SP);
1719     PUSHLOOP(cx, 0, SP);
1720
1721     RETURN;
1722 }
1723
1724 PP(pp_leaveloop)
1725 {
1726     djSP;
1727     register PERL_CONTEXT *cx;
1728     struct block_loop cxloop;
1729     I32 gimme;
1730     SV **newsp;
1731     PMOP *newpm;
1732     SV **mark;
1733
1734     POPBLOCK(cx,newpm);
1735     mark = newsp;
1736     POPLOOP1(cx);       /* Delay POPLOOP2 until stack values are safe */
1737
1738     TAINT_NOT;
1739     if (gimme == G_VOID)
1740         ; /* do nothing */
1741     else if (gimme == G_SCALAR) {
1742         if (mark < SP)
1743             *++newsp = sv_mortalcopy(*SP);
1744         else
1745             *++newsp = &PL_sv_undef;
1746     }
1747     else {
1748         while (mark < SP) {
1749             *++newsp = sv_mortalcopy(*++mark);
1750             TAINT_NOT;          /* Each item is independent */
1751         }
1752     }
1753     SP = newsp;
1754     PUTBACK;
1755
1756     POPLOOP2();         /* Stack values are safe: release loop vars ... */
1757     PL_curpm = newpm;   /* ... and pop $1 et al */
1758
1759     LEAVE;
1760     LEAVE;
1761
1762     return NORMAL;
1763 }
1764
1765 PP(pp_return)
1766 {
1767     djSP; dMARK;
1768     I32 cxix;
1769     register PERL_CONTEXT *cx;
1770     struct block_sub cxsub;
1771     bool popsub2 = FALSE;
1772     I32 gimme;
1773     SV **newsp;
1774     PMOP *newpm;
1775     I32 optype = 0;
1776
1777     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1778         if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1779             if (cxstack_ix > PL_sortcxix)
1780                 dounwind(PL_sortcxix);
1781             AvARRAY(PL_curstack)[1] = *SP;
1782             PL_stack_sp = PL_stack_base + 1;
1783             return 0;
1784         }
1785     }
1786
1787     cxix = dopoptosub(cxstack_ix);
1788     if (cxix < 0)
1789         DIE("Can't return outside a subroutine");
1790     if (cxix < cxstack_ix)
1791         dounwind(cxix);
1792
1793     POPBLOCK(cx,newpm);
1794     switch (CxTYPE(cx)) {
1795     case CXt_SUB:
1796         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1797         popsub2 = TRUE;
1798         break;
1799     case CXt_EVAL:
1800         POPEVAL(cx);
1801         if (optype == OP_REQUIRE &&
1802             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1803         {
1804             /* Unassume the success we assumed earlier. */
1805             char *name = cx->blk_eval.old_name;
1806             (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1807             DIE("%s did not return a true value", name);
1808         }
1809         break;
1810     default:
1811         DIE("panic: return");
1812     }
1813
1814     TAINT_NOT;
1815     if (gimme == G_SCALAR) {
1816         if (MARK < SP) {
1817             if (popsub2) {
1818                 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1819                     if (SvTEMP(TOPs)) {
1820                         *++newsp = SvREFCNT_inc(*SP);
1821                         FREETMPS;
1822                         sv_2mortal(*newsp);
1823                     } else {
1824                         FREETMPS;
1825                         *++newsp = sv_mortalcopy(*SP);
1826                     }
1827                 } else
1828                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1829             } else
1830                 *++newsp = sv_mortalcopy(*SP);
1831         } else
1832             *++newsp = &PL_sv_undef;
1833     }
1834     else if (gimme == G_ARRAY) {
1835         while (++MARK <= SP) {
1836             *++newsp = (popsub2 && SvTEMP(*MARK))
1837                         ? *MARK : sv_mortalcopy(*MARK);
1838             TAINT_NOT;          /* Each item is independent */
1839         }
1840     }
1841     PL_stack_sp = newsp;
1842
1843     /* Stack values are safe: */
1844     if (popsub2) {
1845         POPSUB2();      /* release CV and @_ ... */
1846     }
1847     PL_curpm = newpm;   /* ... and pop $1 et al */
1848
1849     LEAVE;
1850     return pop_return();
1851 }
1852
1853 PP(pp_last)
1854 {
1855     djSP;
1856     I32 cxix;
1857     register PERL_CONTEXT *cx;
1858     struct block_loop cxloop;
1859     struct block_sub cxsub;
1860     I32 pop2 = 0;
1861     I32 gimme;
1862     I32 optype;
1863     OP *nextop;
1864     SV **newsp;
1865     PMOP *newpm;
1866     SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1867
1868     if (PL_op->op_flags & OPf_SPECIAL) {
1869         cxix = dopoptoloop(cxstack_ix);
1870         if (cxix < 0)
1871             DIE("Can't \"last\" outside a block");
1872     }
1873     else {
1874         cxix = dopoptolabel(cPVOP->op_pv);
1875         if (cxix < 0)
1876             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1877     }
1878     if (cxix < cxstack_ix)
1879         dounwind(cxix);
1880
1881     POPBLOCK(cx,newpm);
1882     switch (CxTYPE(cx)) {
1883     case CXt_LOOP:
1884         POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
1885         pop2 = CXt_LOOP;
1886         nextop = cxloop.last_op->op_next;
1887         break;
1888     case CXt_SUB:
1889         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1890         pop2 = CXt_SUB;
1891         nextop = pop_return();
1892         break;
1893     case CXt_EVAL:
1894         POPEVAL(cx);
1895         nextop = pop_return();
1896         break;
1897     default:
1898         DIE("panic: last");
1899     }
1900
1901     TAINT_NOT;
1902     if (gimme == G_SCALAR) {
1903         if (MARK < SP)
1904             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1905                         ? *SP : sv_mortalcopy(*SP);
1906         else
1907             *++newsp = &PL_sv_undef;
1908     }
1909     else if (gimme == G_ARRAY) {
1910         while (++MARK <= SP) {
1911             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1912                         ? *MARK : sv_mortalcopy(*MARK);
1913             TAINT_NOT;          /* Each item is independent */
1914         }
1915     }
1916     SP = newsp;
1917     PUTBACK;
1918
1919     /* Stack values are safe: */
1920     switch (pop2) {
1921     case CXt_LOOP:
1922         POPLOOP2();     /* release loop vars ... */
1923         LEAVE;
1924         break;
1925     case CXt_SUB:
1926         POPSUB2();      /* release CV and @_ ... */
1927         break;
1928     }
1929     PL_curpm = newpm;   /* ... and pop $1 et al */
1930
1931     LEAVE;
1932     return nextop;
1933 }
1934
1935 PP(pp_next)
1936 {
1937     I32 cxix;
1938     register PERL_CONTEXT *cx;
1939     I32 oldsave;
1940
1941     if (PL_op->op_flags & OPf_SPECIAL) {
1942         cxix = dopoptoloop(cxstack_ix);
1943         if (cxix < 0)
1944             DIE("Can't \"next\" outside a block");
1945     }
1946     else {
1947         cxix = dopoptolabel(cPVOP->op_pv);
1948         if (cxix < 0)
1949             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1950     }
1951     if (cxix < cxstack_ix)
1952         dounwind(cxix);
1953
1954     TOPBLOCK(cx);
1955     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1956     LEAVE_SCOPE(oldsave);
1957     return cx->blk_loop.next_op;
1958 }
1959
1960 PP(pp_redo)
1961 {
1962     I32 cxix;
1963     register PERL_CONTEXT *cx;
1964     I32 oldsave;
1965
1966     if (PL_op->op_flags & OPf_SPECIAL) {
1967         cxix = dopoptoloop(cxstack_ix);
1968         if (cxix < 0)
1969             DIE("Can't \"redo\" outside a block");
1970     }
1971     else {
1972         cxix = dopoptolabel(cPVOP->op_pv);
1973         if (cxix < 0)
1974             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1975     }
1976     if (cxix < cxstack_ix)
1977         dounwind(cxix);
1978
1979     TOPBLOCK(cx);
1980     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1981     LEAVE_SCOPE(oldsave);
1982     return cx->blk_loop.redo_op;
1983 }
1984
1985 STATIC OP *
1986 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1987 {
1988     OP *kid;
1989     OP **ops = opstack;
1990     static char too_deep[] = "Target of goto is too deeply nested";
1991
1992     if (ops >= oplimit)
1993         croak(too_deep);
1994     if (o->op_type == OP_LEAVE ||
1995         o->op_type == OP_SCOPE ||
1996         o->op_type == OP_LEAVELOOP ||
1997         o->op_type == OP_LEAVETRY)
1998     {
1999         *ops++ = cUNOPo->op_first;
2000         if (ops >= oplimit)
2001             croak(too_deep);
2002     }
2003     *ops = 0;
2004     if (o->op_flags & OPf_KIDS) {
2005         dTHR;
2006         /* First try all the kids at this level, since that's likeliest. */
2007         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2008             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2009                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2010                 return kid;
2011         }
2012         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2013             if (kid == PL_lastgotoprobe)
2014                 continue;
2015             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2016                 (ops == opstack ||
2017                  (ops[-1]->op_type != OP_NEXTSTATE &&
2018                   ops[-1]->op_type != OP_DBSTATE)))
2019                 *ops++ = kid;
2020             if (o = dofindlabel(kid, label, ops, oplimit))
2021                 return o;
2022         }
2023     }
2024     *ops = 0;
2025     return 0;
2026 }
2027
2028 PP(pp_dump)
2029 {
2030     return pp_goto(ARGS);
2031     /*NOTREACHED*/
2032 }
2033
2034 PP(pp_goto)
2035 {
2036     djSP;
2037     OP *retop = 0;
2038     I32 ix;
2039     register PERL_CONTEXT *cx;
2040 #define GOTO_DEPTH 64
2041     OP *enterops[GOTO_DEPTH];
2042     char *label;
2043     int do_dump = (PL_op->op_type == OP_DUMP);
2044     static char must_have_label[] = "goto must have label";
2045
2046     label = 0;
2047     if (PL_op->op_flags & OPf_STACKED) {
2048         SV *sv = POPs;
2049         STRLEN n_a;
2050
2051         /* This egregious kludge implements goto &subroutine */
2052         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2053             I32 cxix;
2054             register PERL_CONTEXT *cx;
2055             CV* cv = (CV*)SvRV(sv);
2056             SV** mark;
2057             I32 items = 0;
2058             I32 oldsave;
2059             int arg_was_real = 0;
2060
2061         retry:
2062             if (!CvROOT(cv) && !CvXSUB(cv)) {
2063                 GV *gv = CvGV(cv);
2064                 GV *autogv;
2065                 if (gv) {
2066                     SV *tmpstr;
2067                     /* autoloaded stub? */
2068                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2069                         goto retry;
2070                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2071                                           GvNAMELEN(gv), FALSE);
2072                     if (autogv && (cv = GvCV(autogv)))
2073                         goto retry;
2074                     tmpstr = sv_newmortal();
2075                     gv_efullname3(tmpstr, gv, Nullch);
2076                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2077                 }
2078                 DIE("Goto undefined subroutine");
2079             }
2080
2081             /* First do some returnish stuff. */
2082             cxix = dopoptosub(cxstack_ix);
2083             if (cxix < 0)
2084                 DIE("Can't goto subroutine outside a subroutine");
2085             if (cxix < cxstack_ix)
2086                 dounwind(cxix);
2087             TOPBLOCK(cx);
2088             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2089                 DIE("Can't goto subroutine from an eval-string");
2090             mark = PL_stack_sp;
2091             if (CxTYPE(cx) == CXt_SUB &&
2092                 cx->blk_sub.hasargs) {   /* put @_ back onto stack */
2093                 AV* av = cx->blk_sub.argarray;
2094
2095                 items = AvFILLp(av) + 1;
2096                 PL_stack_sp++;
2097                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2098                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2099                 PL_stack_sp += items;
2100 #ifndef USE_THREADS
2101                 SvREFCNT_dec(GvAV(PL_defgv));
2102                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2103 #endif /* USE_THREADS */
2104                 if (AvREAL(av)) {
2105                     arg_was_real = 1;
2106                     AvREAL_off(av);     /* so av_clear() won't clobber elts */
2107                 }
2108                 av_clear(av);
2109             }
2110             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2111                 AV* av;
2112                 int i;
2113 #ifdef USE_THREADS
2114                 av = (AV*)PL_curpad[0];
2115 #else
2116                 av = GvAV(PL_defgv);
2117 #endif
2118                 items = AvFILLp(av) + 1;
2119                 PL_stack_sp++;
2120                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2121                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2122                 PL_stack_sp += items;
2123             }
2124             if (CxTYPE(cx) == CXt_SUB &&
2125                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2126                 SvREFCNT_dec(cx->blk_sub.cv);
2127             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2128             LEAVE_SCOPE(oldsave);
2129
2130             /* Now do some callish stuff. */
2131             SAVETMPS;
2132             if (CvXSUB(cv)) {
2133 #ifdef PERL_XSUB_OLDSTYLE
2134                 if (CvOLDSTYLE(cv)) {
2135                     I32 (*fp3)_((int,int,int));
2136                     while (SP > mark) {
2137                         SP[1] = SP[0];
2138                         SP--;
2139                     }
2140                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2141                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2142                                    mark - PL_stack_base + 1,
2143                                    items);
2144                     SP = PL_stack_base + items;
2145                 }
2146                 else
2147 #endif /* PERL_XSUB_OLDSTYLE */
2148                 {
2149                     SV **newsp;
2150                     I32 gimme;
2151
2152                     PL_stack_sp--;              /* There is no cv arg. */
2153                     /* Push a mark for the start of arglist */
2154                     PUSHMARK(mark);
2155                     (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2156                     /* Pop the current context like a decent sub should */
2157                     POPBLOCK(cx, PL_curpm);
2158                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2159                 }
2160                 LEAVE;
2161                 return pop_return();
2162             }
2163             else {
2164                 AV* padlist = CvPADLIST(cv);
2165                 SV** svp = AvARRAY(padlist);
2166                 if (CxTYPE(cx) == CXt_EVAL) {
2167                     PL_in_eval = cx->blk_eval.old_in_eval;
2168                     PL_eval_root = cx->blk_eval.old_eval_root;
2169                     cx->cx_type = CXt_SUB;
2170                     cx->blk_sub.hasargs = 0;
2171                 }
2172                 cx->blk_sub.cv = cv;
2173                 cx->blk_sub.olddepth = CvDEPTH(cv);
2174                 CvDEPTH(cv)++;
2175                 if (CvDEPTH(cv) < 2)
2176                     (void)SvREFCNT_inc(cv);
2177                 else {  /* save temporaries on recursion? */
2178                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2179                         sub_crush_depth(cv);
2180                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2181                         AV *newpad = newAV();
2182                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2183                         I32 ix = AvFILLp((AV*)svp[1]);
2184                         svp = AvARRAY(svp[0]);
2185                         for ( ;ix > 0; ix--) {
2186                             if (svp[ix] != &PL_sv_undef) {
2187                                 char *name = SvPVX(svp[ix]);
2188                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2189                                     || *name == '&')
2190                                 {
2191                                     /* outer lexical or anon code */
2192                                     av_store(newpad, ix,
2193                                         SvREFCNT_inc(oldpad[ix]) );
2194                                 }
2195                                 else {          /* our own lexical */
2196                                     if (*name == '@')
2197                                         av_store(newpad, ix, sv = (SV*)newAV());
2198                                     else if (*name == '%')
2199                                         av_store(newpad, ix, sv = (SV*)newHV());
2200                                     else
2201                                         av_store(newpad, ix, sv = NEWSV(0,0));
2202                                     SvPADMY_on(sv);
2203                                 }
2204                             }
2205                             else {
2206                                 av_store(newpad, ix, sv = NEWSV(0,0));
2207                                 SvPADTMP_on(sv);
2208                             }
2209                         }
2210                         if (cx->blk_sub.hasargs) {
2211                             AV* av = newAV();
2212                             av_extend(av, 0);
2213                             av_store(newpad, 0, (SV*)av);
2214                             AvFLAGS(av) = AVf_REIFY;
2215                         }
2216                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2217                         AvFILLp(padlist) = CvDEPTH(cv);
2218                         svp = AvARRAY(padlist);
2219                     }
2220                 }
2221 #ifdef USE_THREADS
2222                 if (!cx->blk_sub.hasargs) {
2223                     AV* av = (AV*)PL_curpad[0];
2224
2225                     items = AvFILLp(av) + 1;
2226                     if (items) {
2227                         /* Mark is at the end of the stack. */
2228                         EXTEND(SP, items);
2229                         Copy(AvARRAY(av), SP + 1, items, SV*);
2230                         SP += items;
2231                         PUTBACK ;
2232                     }
2233                 }
2234 #endif /* USE_THREADS */
2235                 SAVESPTR(PL_curpad);
2236                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2237 #ifndef USE_THREADS
2238                 if (cx->blk_sub.hasargs)
2239 #endif /* USE_THREADS */
2240                 {
2241                     AV* av = (AV*)PL_curpad[0];
2242                     SV** ary;
2243
2244 #ifndef USE_THREADS
2245                     cx->blk_sub.savearray = GvAV(PL_defgv);
2246                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2247 #endif /* USE_THREADS */
2248                     cx->blk_sub.argarray = av;
2249                     ++mark;
2250
2251                     if (items >= AvMAX(av) + 1) {
2252                         ary = AvALLOC(av);
2253                         if (AvARRAY(av) != ary) {
2254                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2255                             SvPVX(av) = (char*)ary;
2256                         }
2257                         if (items >= AvMAX(av) + 1) {
2258                             AvMAX(av) = items - 1;
2259                             Renew(ary,items+1,SV*);
2260                             AvALLOC(av) = ary;
2261                             SvPVX(av) = (char*)ary;
2262                         }
2263                     }
2264                     Copy(mark,AvARRAY(av),items,SV*);
2265                     AvFILLp(av) = items - 1;
2266                     /* preserve @_ nature */
2267                     if (arg_was_real) {
2268                         AvREIFY_off(av);
2269                         AvREAL_on(av);
2270                     }
2271                     while (items--) {
2272                         if (*mark)
2273                             SvTEMP_off(*mark);
2274                         mark++;
2275                     }
2276                 }
2277                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2278                     /*
2279                      * We do not care about using sv to call CV;
2280                      * it's for informational purposes only.
2281                      */
2282                     SV *sv = GvSV(PL_DBsub);
2283                     CV *gotocv;
2284
2285                     if (PERLDB_SUB_NN) {
2286                         SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2287                     } else {
2288                         save_item(sv);
2289                         gv_efullname3(sv, CvGV(cv), Nullch);
2290                     }
2291                     if (  PERLDB_GOTO
2292                           && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2293                         PUSHMARK( PL_stack_sp );
2294                         perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2295                         PL_stack_sp--;
2296                     }
2297                 }
2298                 RETURNOP(CvSTART(cv));
2299             }
2300         }
2301         else {
2302             label = SvPV(sv,n_a);
2303             if (!(do_dump || *label))
2304                 DIE(must_have_label);
2305         }
2306     }
2307     else if (PL_op->op_flags & OPf_SPECIAL) {
2308         if (! do_dump)
2309             DIE(must_have_label);
2310     }
2311     else
2312         label = cPVOP->op_pv;
2313
2314     if (label && *label) {
2315         OP *gotoprobe = 0;
2316
2317         /* find label */
2318
2319         PL_lastgotoprobe = 0;
2320         *enterops = 0;
2321         for (ix = cxstack_ix; ix >= 0; ix--) {
2322             cx = &cxstack[ix];
2323             switch (CxTYPE(cx)) {
2324             case CXt_EVAL:
2325                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2326                 break;
2327             case CXt_LOOP:
2328                 gotoprobe = cx->blk_oldcop->op_sibling;
2329                 break;
2330             case CXt_SUBST:
2331                 continue;
2332             case CXt_BLOCK:
2333                 if (ix)
2334                     gotoprobe = cx->blk_oldcop->op_sibling;
2335                 else
2336                     gotoprobe = PL_main_root;
2337                 break;
2338             case CXt_SUB:
2339                 if (CvDEPTH(cx->blk_sub.cv)) {
2340                     gotoprobe = CvROOT(cx->blk_sub.cv);
2341                     break;
2342                 }
2343                 /* FALL THROUGH */
2344             case CXt_NULL:
2345                 DIE("Can't \"goto\" outside a block");
2346             default:
2347                 if (ix)
2348                     DIE("panic: goto");
2349                 gotoprobe = PL_main_root;
2350                 break;
2351             }
2352             retop = dofindlabel(gotoprobe, label,
2353                                 enterops, enterops + GOTO_DEPTH);
2354             if (retop)
2355                 break;
2356             PL_lastgotoprobe = gotoprobe;
2357         }
2358         if (!retop)
2359             DIE("Can't find label %s", label);
2360
2361         /* pop unwanted frames */
2362
2363         if (ix < cxstack_ix) {
2364             I32 oldsave;
2365
2366             if (ix < 0)
2367                 ix = 0;
2368             dounwind(ix);
2369             TOPBLOCK(cx);
2370             oldsave = PL_scopestack[PL_scopestack_ix];
2371             LEAVE_SCOPE(oldsave);
2372         }
2373
2374         /* push wanted frames */
2375
2376         if (*enterops && enterops[1]) {
2377             OP *oldop = PL_op;
2378             for (ix = 1; enterops[ix]; ix++) {
2379                 PL_op = enterops[ix];
2380                 /* Eventually we may want to stack the needed arguments
2381                  * for each op.  For now, we punt on the hard ones. */
2382                 if (PL_op->op_type == OP_ENTERITER)
2383                     DIE("Can't \"goto\" into the middle of a foreach loop",
2384                         label);
2385                 (CALLOP->op_ppaddr)(ARGS);
2386             }
2387             PL_op = oldop;
2388         }
2389     }
2390
2391     if (do_dump) {
2392 #ifdef VMS
2393         if (!retop) retop = PL_main_start;
2394 #endif
2395         PL_restartop = retop;
2396         PL_do_undump = TRUE;
2397
2398         my_unexec();
2399
2400         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2401         PL_do_undump = FALSE;
2402     }
2403
2404     RETURNOP(retop);
2405 }
2406
2407 PP(pp_exit)
2408 {
2409     djSP;
2410     I32 anum;
2411
2412     if (MAXARG < 1)
2413         anum = 0;
2414     else {
2415         anum = SvIVx(POPs);
2416 #ifdef VMSISH_EXIT
2417         if (anum == 1 && VMSISH_EXIT)
2418             anum = 0;
2419 #endif
2420     }
2421     my_exit(anum);
2422     PUSHs(&PL_sv_undef);
2423     RETURN;
2424 }
2425
2426 #ifdef NOTYET
2427 PP(pp_nswitch)
2428 {
2429     djSP;
2430     double value = SvNVx(GvSV(cCOP->cop_gv));
2431     register I32 match = I_32(value);
2432
2433     if (value < 0.0) {
2434         if (((double)match) > value)
2435             --match;            /* was fractional--truncate other way */
2436     }
2437     match -= cCOP->uop.scop.scop_offset;
2438     if (match < 0)
2439         match = 0;
2440     else if (match > cCOP->uop.scop.scop_max)
2441         match = cCOP->uop.scop.scop_max;
2442     PL_op = cCOP->uop.scop.scop_next[match];
2443     RETURNOP(PL_op);
2444 }
2445
2446 PP(pp_cswitch)
2447 {
2448     djSP;
2449     register I32 match;
2450
2451     if (PL_multiline)
2452         PL_op = PL_op->op_next;                 /* can't assume anything */
2453     else {
2454         STRLEN n_a;
2455         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2456         match -= cCOP->uop.scop.scop_offset;
2457         if (match < 0)
2458             match = 0;
2459         else if (match > cCOP->uop.scop.scop_max)
2460             match = cCOP->uop.scop.scop_max;
2461         PL_op = cCOP->uop.scop.scop_next[match];
2462     }
2463     RETURNOP(PL_op);
2464 }
2465 #endif
2466
2467 /* Eval. */
2468
2469 STATIC void
2470 save_lines(AV *array, SV *sv)
2471 {
2472     register char *s = SvPVX(sv);
2473     register char *send = SvPVX(sv) + SvCUR(sv);
2474     register char *t;
2475     register I32 line = 1;
2476
2477     while (s && s < send) {
2478         SV *tmpstr = NEWSV(85,0);
2479
2480         sv_upgrade(tmpstr, SVt_PVMG);
2481         t = strchr(s, '\n');
2482         if (t)
2483             t++;
2484         else
2485             t = send;
2486
2487         sv_setpvn(tmpstr, s, t - s);
2488         av_store(array, line++, tmpstr);
2489         s = t;
2490     }
2491 }
2492
2493 STATIC OP *
2494 docatch(OP *o)
2495 {
2496     dTHR;
2497     int ret;
2498     OP *oldop = PL_op;
2499     dJMPENV;
2500
2501     PL_op = o;
2502 #ifdef DEBUGGING
2503     assert(CATCH_GET == TRUE);
2504     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2505 #endif
2506     JMPENV_PUSH(ret);
2507     switch (ret) {
2508     default:                            /* topmost level handles it */
2509 pass_the_buck:
2510         JMPENV_POP;
2511         PL_op = oldop;
2512         JMPENV_JUMP(ret);
2513         /* NOTREACHED */
2514     case 3:
2515         if (!PL_restartop)
2516             goto pass_the_buck;
2517         PL_op = PL_restartop;
2518         PL_restartop = 0;
2519         /* FALL THROUGH */
2520     case 0:
2521         CALLRUNOPS();
2522         break;
2523     }
2524     JMPENV_POP;
2525     PL_op = oldop;
2526     return Nullop;
2527 }
2528
2529 OP *
2530 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2531 /* sv Text to convert to OP tree. */
2532 /* startop op_free() this to undo. */
2533 /* code Short string id of the caller. */
2534 {
2535     dSP;                                /* Make POPBLOCK work. */
2536     PERL_CONTEXT *cx;
2537     SV **newsp;
2538     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2539     I32 optype;
2540     OP dummy;
2541     OP *oop = PL_op, *rop;
2542     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2543     char *safestr;
2544
2545     ENTER;
2546     lex_start(sv);
2547     SAVETMPS;
2548     /* switch to eval mode */
2549
2550     if (PL_curcop == &PL_compiling) {
2551         SAVESPTR(PL_compiling.cop_stash);
2552         PL_compiling.cop_stash = PL_curstash;
2553     }
2554     SAVESPTR(PL_compiling.cop_filegv);
2555     SAVEI16(PL_compiling.cop_line);
2556     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2557     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2558     PL_compiling.cop_line = 1;
2559     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2560        deleting the eval's FILEGV from the stash before gv_check() runs
2561        (i.e. before run-time proper). To work around the coredump that
2562        ensues, we always turn GvMULTI_on for any globals that were
2563        introduced within evals. See force_ident(). GSAR 96-10-12 */
2564     safestr = savepv(tmpbuf);
2565     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2566     SAVEHINTS();
2567 #ifdef OP_IN_REGISTER
2568     PL_opsave = op;
2569 #else
2570     SAVEPPTR(PL_op);
2571 #endif
2572     PL_hints = 0;
2573
2574     PL_op = &dummy;
2575     PL_op->op_type = OP_ENTEREVAL;
2576     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2577     PUSHBLOCK(cx, CXt_EVAL, SP);
2578     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2579     rop = doeval(G_SCALAR, startop);
2580     POPBLOCK(cx,PL_curpm);
2581     POPEVAL(cx);
2582
2583     (*startop)->op_type = OP_NULL;
2584     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2585     lex_end();
2586     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2587     LEAVE;
2588     if (PL_curcop == &PL_compiling)
2589         PL_compiling.op_private = PL_hints;
2590 #ifdef OP_IN_REGISTER
2591     op = PL_opsave;
2592 #endif
2593     return rop;
2594 }
2595
2596 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2597 STATIC OP *
2598 doeval(int gimme, OP** startop)
2599 {
2600     dSP;
2601     OP *saveop = PL_op;
2602     HV *newstash;
2603     CV *caller;
2604     AV* comppadlist;
2605     I32 i;
2606
2607     PL_in_eval = 1;
2608
2609     PUSHMARK(SP);
2610
2611     /* set up a scratch pad */
2612
2613     SAVEI32(PL_padix);
2614     SAVESPTR(PL_curpad);
2615     SAVESPTR(PL_comppad);
2616     SAVESPTR(PL_comppad_name);
2617     SAVEI32(PL_comppad_name_fill);
2618     SAVEI32(PL_min_intro_pending);
2619     SAVEI32(PL_max_intro_pending);
2620
2621     caller = PL_compcv;
2622     for (i = cxstack_ix - 1; i >= 0; i--) {
2623         PERL_CONTEXT *cx = &cxstack[i];
2624         if (CxTYPE(cx) == CXt_EVAL)
2625             break;
2626         else if (CxTYPE(cx) == CXt_SUB) {
2627             caller = cx->blk_sub.cv;
2628             break;
2629         }
2630     }
2631
2632     SAVESPTR(PL_compcv);
2633     PL_compcv = (CV*)NEWSV(1104,0);
2634     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2635     CvEVAL_on(PL_compcv);
2636 #ifdef USE_THREADS
2637     CvOWNER(PL_compcv) = 0;
2638     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2639     MUTEX_INIT(CvMUTEXP(PL_compcv));
2640 #endif /* USE_THREADS */
2641
2642     PL_comppad = newAV();
2643     av_push(PL_comppad, Nullsv);
2644     PL_curpad = AvARRAY(PL_comppad);
2645     PL_comppad_name = newAV();
2646     PL_comppad_name_fill = 0;
2647     PL_min_intro_pending = 0;
2648     PL_padix = 0;
2649 #ifdef USE_THREADS
2650     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2651     PL_curpad[0] = (SV*)newAV();
2652     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2653 #endif /* USE_THREADS */
2654
2655     comppadlist = newAV();
2656     AvREAL_off(comppadlist);
2657     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2658     av_store(comppadlist, 1, (SV*)PL_comppad);
2659     CvPADLIST(PL_compcv) = comppadlist;
2660
2661     if (!saveop || saveop->op_type != OP_REQUIRE)
2662         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2663
2664     SAVEFREESV(PL_compcv);
2665
2666     /* make sure we compile in the right package */
2667
2668     newstash = PL_curcop->cop_stash;
2669     if (PL_curstash != newstash) {
2670         SAVESPTR(PL_curstash);
2671         PL_curstash = newstash;
2672     }
2673     SAVESPTR(PL_beginav);
2674     PL_beginav = newAV();
2675     SAVEFREESV(PL_beginav);
2676
2677     /* try to compile it */
2678
2679     PL_eval_root = Nullop;
2680     PL_error_count = 0;
2681     PL_curcop = &PL_compiling;
2682     PL_curcop->cop_arybase = 0;
2683     SvREFCNT_dec(PL_rs);
2684     PL_rs = newSVpvn("\n", 1);
2685     if (saveop && saveop->op_flags & OPf_SPECIAL)
2686         PL_in_eval |= 4;
2687     else
2688         sv_setpv(ERRSV,"");
2689     if (yyparse() || PL_error_count || !PL_eval_root) {
2690         SV **newsp;
2691         I32 gimme;
2692         PERL_CONTEXT *cx;
2693         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2694         STRLEN n_a;
2695
2696         PL_op = saveop;
2697         if (PL_eval_root) {
2698             op_free(PL_eval_root);
2699             PL_eval_root = Nullop;
2700         }
2701         SP = PL_stack_base + POPMARK;           /* pop original mark */
2702         if (!startop) {
2703             POPBLOCK(cx,PL_curpm);
2704             POPEVAL(cx);
2705             pop_return();
2706         }
2707         lex_end();
2708         LEAVE;
2709         if (optype == OP_REQUIRE) {
2710             char* msg = SvPVx(ERRSV, n_a);
2711             DIE("%s", *msg ? msg : "Compilation failed in require");
2712         } else if (startop) {
2713             char* msg = SvPVx(ERRSV, n_a);
2714
2715             POPBLOCK(cx,PL_curpm);
2716             POPEVAL(cx);
2717             croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2718         }
2719         SvREFCNT_dec(PL_rs);
2720         PL_rs = SvREFCNT_inc(PL_nrs);
2721 #ifdef USE_THREADS
2722         MUTEX_LOCK(&PL_eval_mutex);
2723         PL_eval_owner = 0;
2724         COND_SIGNAL(&PL_eval_cond);
2725         MUTEX_UNLOCK(&PL_eval_mutex);
2726 #endif /* USE_THREADS */
2727         RETPUSHUNDEF;
2728     }
2729     SvREFCNT_dec(PL_rs);
2730     PL_rs = SvREFCNT_inc(PL_nrs);
2731     PL_compiling.cop_line = 0;
2732     if (startop) {
2733         *startop = PL_eval_root;
2734         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2735         CvOUTSIDE(PL_compcv) = Nullcv;
2736     } else
2737         SAVEFREEOP(PL_eval_root);
2738     if (gimme & G_VOID)
2739         scalarvoid(PL_eval_root);
2740     else if (gimme & G_ARRAY)
2741         list(PL_eval_root);
2742     else
2743         scalar(PL_eval_root);
2744
2745     DEBUG_x(dump_eval());
2746
2747     /* Register with debugger: */
2748     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2749         CV *cv = perl_get_cv("DB::postponed", FALSE);
2750         if (cv) {
2751             dSP;
2752             PUSHMARK(SP);
2753             XPUSHs((SV*)PL_compiling.cop_filegv);
2754             PUTBACK;
2755             perl_call_sv((SV*)cv, G_DISCARD);
2756         }
2757     }
2758
2759     /* compiled okay, so do it */
2760
2761     CvDEPTH(PL_compcv) = 1;
2762     SP = PL_stack_base + POPMARK;               /* pop original mark */
2763     PL_op = saveop;                     /* The caller may need it. */
2764 #ifdef USE_THREADS
2765     MUTEX_LOCK(&PL_eval_mutex);
2766     PL_eval_owner = 0;
2767     COND_SIGNAL(&PL_eval_cond);
2768     MUTEX_UNLOCK(&PL_eval_mutex);
2769 #endif /* USE_THREADS */
2770
2771     RETURNOP(PL_eval_start);
2772 }
2773
2774 PP(pp_require)
2775 {
2776     djSP;
2777     register PERL_CONTEXT *cx;
2778     SV *sv;
2779     char *name;
2780     STRLEN len;
2781     char *tryname;
2782     SV *namesv = Nullsv;
2783     SV** svp;
2784     I32 gimme = G_SCALAR;
2785     PerlIO *tryrsfp = 0;
2786     STRLEN n_a;
2787
2788     sv = POPs;
2789     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2790         SET_NUMERIC_STANDARD();
2791         if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2792             DIE("Perl %s required--this is only version %s, stopped",
2793                 SvPV(sv,n_a),PL_patchlevel);
2794         RETPUSHYES;
2795     }
2796     name = SvPV(sv, len);
2797     if (!(name && len > 0 && *name))
2798         DIE("Null filename used");
2799     TAINT_PROPER("require");
2800     if (PL_op->op_type == OP_REQUIRE &&
2801       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2802       *svp != &PL_sv_undef)
2803         RETPUSHYES;
2804
2805     /* prepare to compile file */
2806
2807     if (*name == '/' ||
2808         (*name == '.' &&
2809             (name[1] == '/' ||
2810              (name[1] == '.' && name[2] == '/')))
2811 #ifdef DOSISH
2812       || (name[0] && name[1] == ':')
2813 #endif
2814 #ifdef WIN32
2815       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2816 #endif
2817 #ifdef VMS
2818         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2819             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2820 #endif
2821     )
2822     {
2823         tryname = name;
2824         tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2825     }
2826     else {
2827         AV *ar = GvAVn(PL_incgv);
2828         I32 i;
2829 #ifdef VMS
2830         char *unixname;
2831         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2832 #endif
2833         {
2834             namesv = NEWSV(806, 0);
2835             for (i = 0; i <= AvFILL(ar); i++) {
2836                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2837 #ifdef VMS
2838                 char *unixdir;
2839                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2840                     continue;
2841                 sv_setpv(namesv, unixdir);
2842                 sv_catpv(namesv, unixname);
2843 #else
2844                 sv_setpvf(namesv, "%s/%s", dir, name);
2845 #endif
2846                 TAINT_PROPER("require");
2847                 tryname = SvPVX(namesv);
2848                 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2849                 if (tryrsfp) {
2850                     if (tryname[0] == '.' && tryname[1] == '/')
2851                         tryname += 2;
2852                     break;
2853                 }
2854             }
2855         }
2856     }
2857     SAVESPTR(PL_compiling.cop_filegv);
2858     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2859     SvREFCNT_dec(namesv);
2860     if (!tryrsfp) {
2861         if (PL_op->op_type == OP_REQUIRE) {
2862             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2863             SV *dirmsgsv = NEWSV(0, 0);
2864             AV *ar = GvAVn(PL_incgv);
2865             I32 i;
2866             if (instr(SvPVX(msg), ".h "))
2867                 sv_catpv(msg, " (change .h to .ph maybe?)");
2868             if (instr(SvPVX(msg), ".ph "))
2869                 sv_catpv(msg, " (did you run h2ph?)");
2870             sv_catpv(msg, " (@INC contains:");
2871             for (i = 0; i <= AvFILL(ar); i++) {
2872                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2873                 sv_setpvf(dirmsgsv, " %s", dir);
2874                 sv_catsv(msg, dirmsgsv);
2875             }
2876             sv_catpvn(msg, ")", 1);
2877             SvREFCNT_dec(dirmsgsv);
2878             DIE("%_", msg);
2879         }
2880
2881         RETPUSHUNDEF;
2882     }
2883     else
2884         SETERRNO(0, SS$_NORMAL);
2885
2886     /* Assume success here to prevent recursive requirement. */
2887     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2888         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2889
2890     ENTER;
2891     SAVETMPS;
2892     lex_start(sv_2mortal(newSVpvn("",0)));
2893     SAVEGENERICSV(PL_rsfp_filters);
2894     PL_rsfp_filters = Nullav;
2895
2896     PL_rsfp = tryrsfp;
2897     name = savepv(name);
2898     SAVEFREEPV(name);
2899     SAVEHINTS();
2900     PL_hints = 0;
2901     SAVEPPTR(PL_compiling.cop_warnings);
2902     PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2903                                                              : WARN_NONE);
2904
2905     /* switch to eval mode */
2906
2907     push_return(PL_op->op_next);
2908     PUSHBLOCK(cx, CXt_EVAL, SP);
2909     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2910
2911     SAVEI16(PL_compiling.cop_line);
2912     PL_compiling.cop_line = 0;
2913
2914     PUTBACK;
2915 #ifdef USE_THREADS
2916     MUTEX_LOCK(&PL_eval_mutex);
2917     if (PL_eval_owner && PL_eval_owner != thr)
2918         while (PL_eval_owner)
2919             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2920     PL_eval_owner = thr;
2921     MUTEX_UNLOCK(&PL_eval_mutex);
2922 #endif /* USE_THREADS */
2923     return DOCATCH(doeval(G_SCALAR, NULL));
2924 }
2925
2926 PP(pp_dofile)
2927 {
2928     return pp_require(ARGS);
2929 }
2930
2931 PP(pp_entereval)
2932 {
2933     djSP;
2934     register PERL_CONTEXT *cx;
2935     dPOPss;
2936     I32 gimme = GIMME_V, was = PL_sub_generation;
2937     char tmpbuf[TYPE_DIGITS(long) + 12];
2938     char *safestr;
2939     STRLEN len;
2940     OP *ret;
2941
2942     if (!SvPV(sv,len) || !len)
2943         RETPUSHUNDEF;
2944     TAINT_PROPER("eval");
2945
2946     ENTER;
2947     lex_start(sv);
2948     SAVETMPS;
2949
2950     /* switch to eval mode */
2951
2952     SAVESPTR(PL_compiling.cop_filegv);
2953     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2954     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2955     PL_compiling.cop_line = 1;
2956     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2957        deleting the eval's FILEGV from the stash before gv_check() runs
2958        (i.e. before run-time proper). To work around the coredump that
2959        ensues, we always turn GvMULTI_on for any globals that were
2960        introduced within evals. See force_ident(). GSAR 96-10-12 */
2961     safestr = savepv(tmpbuf);
2962     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2963     SAVEHINTS();
2964     PL_hints = PL_op->op_targ;
2965     SAVEPPTR(PL_compiling.cop_warnings);
2966     if (PL_compiling.cop_warnings != WARN_ALL
2967         && PL_compiling.cop_warnings != WARN_NONE){
2968         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2969         SAVEFREESV(PL_compiling.cop_warnings) ;
2970     }
2971
2972     push_return(PL_op->op_next);
2973     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2974     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2975
2976     /* prepare to compile string */
2977
2978     if (PERLDB_LINE && PL_curstash != PL_debstash)
2979         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2980     PUTBACK;
2981 #ifdef USE_THREADS
2982     MUTEX_LOCK(&PL_eval_mutex);
2983     if (PL_eval_owner && PL_eval_owner != thr)
2984         while (PL_eval_owner)
2985             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2986     PL_eval_owner = thr;
2987     MUTEX_UNLOCK(&PL_eval_mutex);
2988 #endif /* USE_THREADS */
2989     ret = doeval(gimme, NULL);
2990     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2991         && ret != PL_op->op_next) {     /* Successive compilation. */
2992         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2993     }
2994     return DOCATCH(ret);
2995 }
2996
2997 PP(pp_leaveeval)
2998 {
2999     djSP;
3000     register SV **mark;
3001     SV **newsp;
3002     PMOP *newpm;
3003     I32 gimme;
3004     register PERL_CONTEXT *cx;
3005     OP *retop;
3006     U8 save_flags = PL_op -> op_flags;
3007     I32 optype;
3008
3009     POPBLOCK(cx,newpm);
3010     POPEVAL(cx);
3011     retop = pop_return();
3012
3013     TAINT_NOT;
3014     if (gimme == G_VOID)
3015         MARK = newsp;
3016     else if (gimme == G_SCALAR) {
3017         MARK = newsp + 1;
3018         if (MARK <= SP) {
3019             if (SvFLAGS(TOPs) & SVs_TEMP)
3020                 *MARK = TOPs;
3021             else
3022                 *MARK = sv_mortalcopy(TOPs);
3023         }
3024         else {
3025             MEXTEND(mark,0);
3026             *MARK = &PL_sv_undef;
3027         }
3028     }
3029     else {
3030         /* in case LEAVE wipes old return values */
3031         for (mark = newsp + 1; mark <= SP; mark++) {
3032             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3033                 *mark = sv_mortalcopy(*mark);
3034                 TAINT_NOT;      /* Each item is independent */
3035             }
3036         }
3037     }
3038     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3039
3040     /*
3041      * Closures mentioned at top level of eval cannot be referenced
3042      * again, and their presence indirectly causes a memory leak.
3043      * (Note that the fact that compcv and friends are still set here
3044      * is, AFAIK, an accident.)  --Chip
3045      */
3046     if (AvFILLp(PL_comppad_name) >= 0) {
3047         SV **svp = AvARRAY(PL_comppad_name);
3048         I32 ix;
3049         for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3050             SV *sv = svp[ix];
3051             if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3052                 SvREFCNT_dec(sv);
3053                 svp[ix] = &PL_sv_undef;
3054
3055                 sv = PL_curpad[ix];
3056                 if (CvCLONE(sv)) {
3057                     SvREFCNT_dec(CvOUTSIDE(sv));
3058                     CvOUTSIDE(sv) = Nullcv;
3059                 }
3060                 else {
3061                     SvREFCNT_dec(sv);
3062                     sv = NEWSV(0,0);
3063                     SvPADTMP_on(sv);
3064                     PL_curpad[ix] = sv;
3065                 }
3066             }
3067         }
3068     }
3069
3070 #ifdef DEBUGGING
3071     assert(CvDEPTH(PL_compcv) == 1);
3072 #endif
3073     CvDEPTH(PL_compcv) = 0;
3074     lex_end();
3075
3076     if (optype == OP_REQUIRE &&
3077         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3078     {
3079         /* Unassume the success we assumed earlier. */
3080         char *name = cx->blk_eval.old_name;
3081         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3082         retop = die("%s did not return a true value", name);
3083         /* die_where() did LEAVE, or we won't be here */
3084     }
3085     else {
3086         LEAVE;
3087         if (!(save_flags & OPf_SPECIAL))
3088             sv_setpv(ERRSV,"");
3089     }
3090
3091     RETURNOP(retop);
3092 }
3093
3094 PP(pp_entertry)
3095 {
3096     djSP;
3097     register PERL_CONTEXT *cx;
3098     I32 gimme = GIMME_V;
3099
3100     ENTER;
3101     SAVETMPS;
3102
3103     push_return(cLOGOP->op_other->op_next);
3104     PUSHBLOCK(cx, CXt_EVAL, SP);
3105     PUSHEVAL(cx, 0, 0);
3106     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3107
3108     PL_in_eval = 1;
3109     sv_setpv(ERRSV,"");
3110     PUTBACK;
3111     return DOCATCH(PL_op->op_next);
3112 }
3113
3114 PP(pp_leavetry)
3115 {
3116     djSP;
3117     register SV **mark;
3118     SV **newsp;
3119     PMOP *newpm;
3120     I32 gimme;
3121     register PERL_CONTEXT *cx;
3122     I32 optype;
3123
3124     POPBLOCK(cx,newpm);
3125     POPEVAL(cx);
3126     pop_return();
3127
3128     TAINT_NOT;
3129     if (gimme == G_VOID)
3130         SP = newsp;
3131     else if (gimme == G_SCALAR) {
3132         MARK = newsp + 1;
3133         if (MARK <= SP) {
3134             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3135                 *MARK = TOPs;
3136             else
3137                 *MARK = sv_mortalcopy(TOPs);
3138         }
3139         else {
3140             MEXTEND(mark,0);
3141             *MARK = &PL_sv_undef;
3142         }
3143         SP = MARK;
3144     }
3145     else {
3146         /* in case LEAVE wipes old return values */
3147         for (mark = newsp + 1; mark <= SP; mark++) {
3148             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3149                 *mark = sv_mortalcopy(*mark);
3150                 TAINT_NOT;      /* Each item is independent */
3151             }
3152         }
3153     }
3154     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3155
3156     LEAVE;
3157     sv_setpv(ERRSV,"");
3158     RETURN;
3159 }
3160
3161 STATIC void
3162 doparseform(SV *sv)
3163 {
3164     STRLEN len;
3165     register char *s = SvPV_force(sv, len);
3166     register char *send = s + len;
3167     register char *base;
3168     register I32 skipspaces = 0;
3169     bool noblank;
3170     bool repeat;
3171     bool postspace = FALSE;
3172     U16 *fops;
3173     register U16 *fpc;
3174     U16 *linepc;
3175     register I32 arg;
3176     bool ischop;
3177
3178     if (len == 0)
3179         croak("Null picture in formline");
3180
3181     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3182     fpc = fops;
3183
3184     if (s < send) {
3185         linepc = fpc;
3186         *fpc++ = FF_LINEMARK;
3187         noblank = repeat = FALSE;
3188         base = s;
3189     }
3190
3191     while (s <= send) {
3192         switch (*s++) {
3193         default:
3194             skipspaces = 0;
3195             continue;
3196
3197         case '~':
3198             if (*s == '~') {
3199                 repeat = TRUE;
3200                 *s = ' ';
3201             }
3202             noblank = TRUE;
3203             s[-1] = ' ';
3204             /* FALL THROUGH */
3205         case ' ': case '\t':
3206             skipspaces++;
3207             continue;
3208
3209         case '\n': case 0:
3210             arg = s - base;
3211             skipspaces++;
3212             arg -= skipspaces;
3213             if (arg) {
3214                 if (postspace)
3215                     *fpc++ = FF_SPACE;
3216                 *fpc++ = FF_LITERAL;
3217                 *fpc++ = arg;
3218             }
3219             postspace = FALSE;
3220             if (s <= send)
3221                 skipspaces--;
3222             if (skipspaces) {
3223                 *fpc++ = FF_SKIP;
3224                 *fpc++ = skipspaces;
3225             }
3226             skipspaces = 0;
3227             if (s <= send)
3228                 *fpc++ = FF_NEWLINE;
3229             if (noblank) {
3230                 *fpc++ = FF_BLANK;
3231                 if (repeat)
3232                     arg = fpc - linepc + 1;
3233                 else
3234                     arg = 0;
3235                 *fpc++ = arg;
3236             }
3237             if (s < send) {
3238                 linepc = fpc;
3239                 *fpc++ = FF_LINEMARK;
3240                 noblank = repeat = FALSE;
3241                 base = s;
3242             }
3243             else
3244                 s++;
3245             continue;
3246
3247         case '@':
3248         case '^':
3249             ischop = s[-1] == '^';
3250
3251             if (postspace) {
3252                 *fpc++ = FF_SPACE;
3253                 postspace = FALSE;
3254             }
3255             arg = (s - base) - 1;
3256             if (arg) {
3257                 *fpc++ = FF_LITERAL;
3258                 *fpc++ = arg;
3259             }
3260
3261             base = s - 1;
3262             *fpc++ = FF_FETCH;
3263             if (*s == '*') {
3264                 s++;
3265                 *fpc++ = 0;
3266                 *fpc++ = FF_LINEGLOB;
3267             }
3268             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3269                 arg = ischop ? 512 : 0;
3270                 base = s - 1;
3271                 while (*s == '#')
3272                     s++;
3273                 if (*s == '.') {
3274                     char *f;
3275                     s++;
3276                     f = s;
3277                     while (*s == '#')
3278                         s++;
3279                     arg |= 256 + (s - f);
3280                 }
3281                 *fpc++ = s - base;              /* fieldsize for FETCH */
3282                 *fpc++ = FF_DECIMAL;
3283                 *fpc++ = arg;
3284             }
3285             else {
3286                 I32 prespace = 0;
3287                 bool ismore = FALSE;
3288
3289                 if (*s == '>') {
3290                     while (*++s == '>') ;
3291                     prespace = FF_SPACE;
3292                 }
3293                 else if (*s == '|') {
3294                     while (*++s == '|') ;
3295                     prespace = FF_HALFSPACE;
3296                     postspace = TRUE;
3297                 }
3298                 else {
3299                     if (*s == '<')
3300                         while (*++s == '<') ;
3301                     postspace = TRUE;
3302                 }
3303                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3304                     s += 3;
3305                     ismore = TRUE;
3306                 }
3307                 *fpc++ = s - base;              /* fieldsize for FETCH */
3308
3309                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3310
3311                 if (prespace)
3312                     *fpc++ = prespace;
3313                 *fpc++ = FF_ITEM;
3314                 if (ismore)
3315                     *fpc++ = FF_MORE;
3316                 if (ischop)
3317                     *fpc++ = FF_CHOP;
3318             }
3319             base = s;
3320             skipspaces = 0;
3321             continue;
3322         }
3323     }
3324     *fpc++ = FF_END;
3325
3326     arg = fpc - fops;
3327     { /* need to jump to the next word */
3328         int z;
3329         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3330         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3331         s = SvPVX(sv) + SvCUR(sv) + z;
3332     }
3333     Copy(fops, s, arg, U16);
3334     Safefree(fops);
3335     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3336     SvCOMPILED_on(sv);
3337 }
3338
3339 /*
3340  * The rest of this file was derived from source code contributed
3341  * by Tom Horsley.
3342  *
3343  * NOTE: this code was derived from Tom Horsley's qsort replacement
3344  * and should not be confused with the original code.
3345  */
3346
3347 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3348
3349    Permission granted to distribute under the same terms as perl which are
3350    (briefly):
3351
3352     This program is free software; you can redistribute it and/or modify
3353     it under the terms of either:
3354
3355         a) the GNU General Public License as published by the Free
3356         Software Foundation; either version 1, or (at your option) any
3357         later version, or
3358
3359         b) the "Artistic License" which comes with this Kit.
3360
3361    Details on the perl license can be found in the perl source code which
3362    may be located via the www.perl.com web page.
3363
3364    This is the most wonderfulest possible qsort I can come up with (and
3365    still be mostly portable) My (limited) tests indicate it consistently
3366    does about 20% fewer calls to compare than does the qsort in the Visual
3367    C++ library, other vendors may vary.
3368
3369    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3370    others I invented myself (or more likely re-invented since they seemed
3371    pretty obvious once I watched the algorithm operate for a while).
3372
3373    Most of this code was written while watching the Marlins sweep the Giants
3374    in the 1997 National League Playoffs - no Braves fans allowed to use this
3375    code (just kidding :-).
3376
3377    I realize that if I wanted to be true to the perl tradition, the only
3378    comment in this file would be something like:
3379
3380    ...they shuffled back towards the rear of the line. 'No, not at the
3381    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3382
3383    However, I really needed to violate that tradition just so I could keep
3384    track of what happens myself, not to mention some poor fool trying to
3385    understand this years from now :-).
3386 */
3387
3388 /* ********************************************************** Configuration */
3389
3390 #ifndef QSORT_ORDER_GUESS
3391 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3392 #endif
3393
3394 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3395    future processing - a good max upper bound is log base 2 of memory size
3396    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3397    safely be smaller than that since the program is taking up some space and
3398    most operating systems only let you grab some subset of contiguous
3399    memory (not to mention that you are normally sorting data larger than
3400    1 byte element size :-).
3401 */
3402 #ifndef QSORT_MAX_STACK
3403 #define QSORT_MAX_STACK 32
3404 #endif
3405
3406 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3407    Anything bigger and we use qsort. If you make this too small, the qsort
3408    will probably break (or become less efficient), because it doesn't expect
3409    the middle element of a partition to be the same as the right or left -
3410    you have been warned).
3411 */
3412 #ifndef QSORT_BREAK_EVEN
3413 #define QSORT_BREAK_EVEN 6
3414 #endif
3415
3416 /* ************************************************************* Data Types */
3417
3418 /* hold left and right index values of a partition waiting to be sorted (the
3419    partition includes both left and right - right is NOT one past the end or
3420    anything like that).
3421 */
3422 struct partition_stack_entry {
3423    int left;
3424    int right;
3425 #ifdef QSORT_ORDER_GUESS
3426    int qsort_break_even;
3427 #endif
3428 };
3429
3430 /* ******************************************************* Shorthand Macros */
3431
3432 /* Note that these macros will be used from inside the qsort function where
3433    we happen to know that the variable 'elt_size' contains the size of an
3434    array element and the variable 'temp' points to enough space to hold a
3435    temp element and the variable 'array' points to the array being sorted
3436    and 'compare' is the pointer to the compare routine.
3437
3438    Also note that there are very many highly architecture specific ways
3439    these might be sped up, but this is simply the most generally portable
3440    code I could think of.
3441 */
3442
3443 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3444 */
3445 #ifdef PERL_OBJECT
3446 #define qsort_cmp(elt1, elt2) \
3447    ((this->*compare)(array[elt1], array[elt2]))
3448 #else
3449 #define qsort_cmp(elt1, elt2) \
3450    ((*compare)(array[elt1], array[elt2]))
3451 #endif
3452
3453 #ifdef QSORT_ORDER_GUESS
3454 #define QSORT_NOTICE_SWAP swapped++;
3455 #else
3456 #define QSORT_NOTICE_SWAP
3457 #endif
3458
3459 /* swaps contents of array elements elt1, elt2.
3460 */
3461 #define qsort_swap(elt1, elt2) \
3462    STMT_START { \
3463       QSORT_NOTICE_SWAP \
3464       temp = array[elt1]; \
3465       array[elt1] = array[elt2]; \
3466       array[elt2] = temp; \
3467    } STMT_END
3468
3469 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3470    elt3 and elt3 gets elt1.
3471 */
3472 #define qsort_rotate(elt1, elt2, elt3) \
3473    STMT_START { \
3474       QSORT_NOTICE_SWAP \
3475       temp = array[elt1]; \
3476       array[elt1] = array[elt2]; \
3477       array[elt2] = array[elt3]; \
3478       array[elt3] = temp; \
3479    } STMT_END
3480
3481 /* ************************************************************ Debug stuff */
3482
3483 #ifdef QSORT_DEBUG
3484
3485 static void
3486 break_here()
3487 {
3488    return; /* good place to set a breakpoint */
3489 }
3490
3491 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3492
3493 static void
3494 doqsort_all_asserts(
3495    void * array,
3496    size_t num_elts,
3497    size_t elt_size,
3498    int (*compare)(const void * elt1, const void * elt2),
3499    int pc_left, int pc_right, int u_left, int u_right)
3500 {
3501    int i;
3502
3503    qsort_assert(pc_left <= pc_right);
3504    qsort_assert(u_right < pc_left);
3505    qsort_assert(pc_right < u_left);
3506    for (i = u_right + 1; i < pc_left; ++i) {
3507       qsort_assert(qsort_cmp(i, pc_left) < 0);
3508    }
3509    for (i = pc_left; i < pc_right; ++i) {
3510       qsort_assert(qsort_cmp(i, pc_right) == 0);
3511    }
3512    for (i = pc_right + 1; i < u_left; ++i) {
3513       qsort_assert(qsort_cmp(pc_right, i) < 0);
3514    }
3515 }
3516
3517 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3518    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3519                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3520
3521 #else
3522
3523 #define qsort_assert(t) ((void)0)
3524
3525 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3526
3527 #endif
3528
3529 /* ****************************************************************** qsort */
3530
3531 STATIC void
3532 #ifdef PERL_OBJECT
3533 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3534 #else
3535 qsortsv(
3536    SV ** array,
3537    size_t num_elts,
3538    I32 (*compare)(SV *a, SV *b))
3539 #endif
3540 {
3541    register SV * temp;
3542
3543    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3544    int next_stack_entry = 0;
3545
3546    int part_left;
3547    int part_right;
3548 #ifdef QSORT_ORDER_GUESS
3549    int qsort_break_even;
3550    int swapped;
3551 #endif
3552
3553    /* Make sure we actually have work to do.
3554    */
3555    if (num_elts <= 1) {
3556       return;
3557    }
3558
3559    /* Setup the initial partition definition and fall into the sorting loop
3560    */
3561    part_left = 0;
3562    part_right = (int)(num_elts - 1);
3563 #ifdef QSORT_ORDER_GUESS
3564    qsort_break_even = QSORT_BREAK_EVEN;
3565 #else
3566 #define qsort_break_even QSORT_BREAK_EVEN
3567 #endif
3568    for ( ; ; ) {
3569       if ((part_right - part_left) >= qsort_break_even) {
3570          /* OK, this is gonna get hairy, so lets try to document all the
3571             concepts and abbreviations and variables and what they keep
3572             track of:
3573
3574             pc: pivot chunk - the set of array elements we accumulate in the
3575                 middle of the partition, all equal in value to the original
3576                 pivot element selected. The pc is defined by:
3577
3578                 pc_left - the leftmost array index of the pc
3579                 pc_right - the rightmost array index of the pc
3580
3581                 we start with pc_left == pc_right and only one element
3582                 in the pivot chunk (but it can grow during the scan).
3583
3584             u:  uncompared elements - the set of elements in the partition
3585                 we have not yet compared to the pivot value. There are two
3586                 uncompared sets during the scan - one to the left of the pc
3587                 and one to the right.
3588
3589                 u_right - the rightmost index of the left side's uncompared set
3590                 u_left - the leftmost index of the right side's uncompared set
3591
3592                 The leftmost index of the left sides's uncompared set
3593                 doesn't need its own variable because it is always defined
3594                 by the leftmost edge of the whole partition (part_left). The
3595                 same goes for the rightmost edge of the right partition
3596                 (part_right).
3597
3598                 We know there are no uncompared elements on the left once we
3599                 get u_right < part_left and no uncompared elements on the
3600                 right once u_left > part_right. When both these conditions
3601                 are met, we have completed the scan of the partition.
3602
3603                 Any elements which are between the pivot chunk and the
3604                 uncompared elements should be less than the pivot value on
3605                 the left side and greater than the pivot value on the right
3606                 side (in fact, the goal of the whole algorithm is to arrange
3607                 for that to be true and make the groups of less-than and
3608                 greater-then elements into new partitions to sort again).
3609
3610             As you marvel at the complexity of the code and wonder why it
3611             has to be so confusing. Consider some of the things this level
3612             of confusion brings:
3613
3614             Once I do a compare, I squeeze every ounce of juice out of it. I
3615             never do compare calls I don't have to do, and I certainly never
3616             do redundant calls.
3617
3618             I also never swap any elements unless I can prove there is a
3619             good reason. Many sort algorithms will swap a known value with
3620             an uncompared value just to get things in the right place (or
3621             avoid complexity :-), but that uncompared value, once it gets
3622             compared, may then have to be swapped again. A lot of the
3623             complexity of this code is due to the fact that it never swaps
3624             anything except compared values, and it only swaps them when the
3625             compare shows they are out of position.
3626          */
3627          int pc_left, pc_right;
3628          int u_right, u_left;
3629
3630          int s;
3631
3632          pc_left = ((part_left + part_right) / 2);
3633          pc_right = pc_left;
3634          u_right = pc_left - 1;
3635          u_left = pc_right + 1;
3636
3637          /* Qsort works best when the pivot value is also the median value
3638             in the partition (unfortunately you can't find the median value
3639             without first sorting :-), so to give the algorithm a helping
3640             hand, we pick 3 elements and sort them and use the median value
3641             of that tiny set as the pivot value.
3642
3643             Some versions of qsort like to use the left middle and right as
3644             the 3 elements to sort so they can insure the ends of the
3645             partition will contain values which will stop the scan in the
3646             compare loop, but when you have to call an arbitrarily complex
3647             routine to do a compare, its really better to just keep track of
3648             array index values to know when you hit the edge of the
3649             partition and avoid the extra compare. An even better reason to
3650             avoid using a compare call is the fact that you can drop off the
3651             edge of the array if someone foolishly provides you with an
3652             unstable compare function that doesn't always provide consistent
3653             results.
3654
3655             So, since it is simpler for us to compare the three adjacent
3656             elements in the middle of the partition, those are the ones we
3657             pick here (conveniently pointed at by u_right, pc_left, and
3658             u_left). The values of the left, center, and right elements
3659             are refered to as l c and r in the following comments.
3660          */
3661
3662 #ifdef QSORT_ORDER_GUESS
3663          swapped = 0;
3664 #endif
3665          s = qsort_cmp(u_right, pc_left);
3666          if (s < 0) {
3667             /* l < c */
3668             s = qsort_cmp(pc_left, u_left);
3669             /* if l < c, c < r - already in order - nothing to do */
3670             if (s == 0) {
3671                /* l < c, c == r - already in order, pc grows */
3672                ++pc_right;
3673                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3674             } else if (s > 0) {
3675                /* l < c, c > r - need to know more */
3676                s = qsort_cmp(u_right, u_left);
3677                if (s < 0) {
3678                   /* l < c, c > r, l < r - swap c & r to get ordered */
3679                   qsort_swap(pc_left, u_left);
3680                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3681                } else if (s == 0) {
3682                   /* l < c, c > r, l == r - swap c&r, grow pc */
3683                   qsort_swap(pc_left, u_left);
3684                   --pc_left;
3685                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3686                } else {
3687                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3688                   qsort_rotate(pc_left, u_right, u_left);
3689                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3690                }
3691             }
3692          } else if (s == 0) {
3693             /* l == c */
3694             s = qsort_cmp(pc_left, u_left);
3695             if (s < 0) {
3696                /* l == c, c < r - already in order, grow pc */
3697                --pc_left;
3698                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3699             } else if (s == 0) {
3700                /* l == c, c == r - already in order, grow pc both ways */
3701                --pc_left;
3702                ++pc_right;
3703                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3704             } else {
3705                /* l == c, c > r - swap l & r, grow pc */
3706                qsort_swap(u_right, u_left);
3707                ++pc_right;
3708                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3709             }
3710          } else {
3711             /* l > c */
3712             s = qsort_cmp(pc_left, u_left);
3713             if (s < 0) {
3714                /* l > c, c < r - need to know more */
3715                s = qsort_cmp(u_right, u_left);
3716                if (s < 0) {
3717                   /* l > c, c < r, l < r - swap l & c to get ordered */
3718                   qsort_swap(u_right, pc_left);
3719                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3720                } else if (s == 0) {
3721                   /* l > c, c < r, l == r - swap l & c, grow pc */
3722                   qsort_swap(u_right, pc_left);
3723                   ++pc_right;
3724                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3725                } else {
3726                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3727                   qsort_rotate(u_right, pc_left, u_left);
3728                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3729                }
3730             } else if (s == 0) {
3731                /* l > c, c == r - swap ends, grow pc */
3732                qsort_swap(u_right, u_left);
3733                --pc_left;
3734                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3735             } else {
3736                /* l > c, c > r - swap ends to get in order */
3737                qsort_swap(u_right, u_left);
3738                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3739             }
3740          }
3741          /* We now know the 3 middle elements have been compared and
3742             arranged in the desired order, so we can shrink the uncompared
3743             sets on both sides
3744          */
3745          --u_right;
3746          ++u_left;
3747          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3748
3749          /* The above massive nested if was the simple part :-). We now have
3750             the middle 3 elements ordered and we need to scan through the
3751             uncompared sets on either side, swapping elements that are on
3752             the wrong side or simply shuffling equal elements around to get
3753             all equal elements into the pivot chunk.
3754          */
3755
3756          for ( ; ; ) {
3757             int still_work_on_left;
3758             int still_work_on_right;
3759
3760             /* Scan the uncompared values on the left. If I find a value
3761                equal to the pivot value, move it over so it is adjacent to
3762                the pivot chunk and expand the pivot chunk. If I find a value
3763                less than the pivot value, then just leave it - its already
3764                on the correct side of the partition. If I find a greater
3765                value, then stop the scan.
3766             */
3767             while (still_work_on_left = (u_right >= part_left)) {
3768                s = qsort_cmp(u_right, pc_left);
3769                if (s < 0) {
3770                   --u_right;
3771                } else if (s == 0) {
3772                   --pc_left;
3773                   if (pc_left != u_right) {
3774                      qsort_swap(u_right, pc_left);
3775                   }
3776                   --u_right;
3777                } else {
3778                   break;
3779                }
3780                qsort_assert(u_right < pc_left);
3781                qsort_assert(pc_left <= pc_right);
3782                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3783                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3784             }
3785
3786             /* Do a mirror image scan of uncompared values on the right
3787             */
3788             while (still_work_on_right = (u_left <= part_right)) {
3789                s = qsort_cmp(pc_right, u_left);
3790                if (s < 0) {
3791                   ++u_left;
3792                } else if (s == 0) {
3793                   ++pc_right;
3794                   if (pc_right != u_left) {
3795                      qsort_swap(pc_right, u_left);
3796                   }
3797                   ++u_left;
3798                } else {
3799                   break;
3800                }
3801                qsort_assert(u_left > pc_right);
3802                qsort_assert(pc_left <= pc_right);
3803                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3804                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3805             }
3806
3807             if (still_work_on_left) {
3808                /* I know I have a value on the left side which needs to be
3809                   on the right side, but I need to know more to decide
3810                   exactly the best thing to do with it.
3811                */
3812                if (still_work_on_right) {
3813                   /* I know I have values on both side which are out of
3814                      position. This is a big win because I kill two birds
3815                      with one swap (so to speak). I can advance the
3816                      uncompared pointers on both sides after swapping both
3817                      of them into the right place.
3818                   */
3819                   qsort_swap(u_right, u_left);
3820                   --u_right;
3821                   ++u_left;
3822                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3823                } else {
3824                   /* I have an out of position value on the left, but the
3825                      right is fully scanned, so I "slide" the pivot chunk
3826                      and any less-than values left one to make room for the
3827                      greater value over on the right. If the out of position
3828                      value is immediately adjacent to the pivot chunk (there
3829                      are no less-than values), I can do that with a swap,
3830                      otherwise, I have to rotate one of the less than values
3831                      into the former position of the out of position value
3832                      and the right end of the pivot chunk into the left end
3833                      (got all that?).
3834                   */
3835                   --pc_left;
3836                   if (pc_left == u_right) {
3837                      qsort_swap(u_right, pc_right);
3838                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3839                   } else {
3840                      qsort_rotate(u_right, pc_left, pc_right);
3841                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3842                   }
3843                   --pc_right;
3844                   --u_right;
3845                }
3846             } else if (still_work_on_right) {
3847                /* Mirror image of complex case above: I have an out of
3848                   position value on the right, but the left is fully
3849                   scanned, so I need to shuffle things around to make room
3850                   for the right value on the left.
3851                */
3852                ++pc_right;
3853                if (pc_right == u_left) {
3854                   qsort_swap(u_left, pc_left);
3855                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3856                } else {
3857                   qsort_rotate(pc_right, pc_left, u_left);
3858                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3859                }
3860                ++pc_left;
3861                ++u_left;
3862             } else {
3863                /* No more scanning required on either side of partition,
3864                   break out of loop and figure out next set of partitions
3865                */
3866                break;
3867             }
3868          }
3869
3870          /* The elements in the pivot chunk are now in the right place. They
3871             will never move or be compared again. All I have to do is decide
3872             what to do with the stuff to the left and right of the pivot
3873             chunk.
3874
3875             Notes on the QSORT_ORDER_GUESS ifdef code:
3876
3877             1. If I just built these partitions without swapping any (or
3878                very many) elements, there is a chance that the elements are
3879                already ordered properly (being properly ordered will
3880                certainly result in no swapping, but the converse can't be
3881                proved :-).
3882
3883             2. A (properly written) insertion sort will run faster on
3884                already ordered data than qsort will.
3885
3886             3. Perhaps there is some way to make a good guess about
3887                switching to an insertion sort earlier than partition size 6
3888                (for instance - we could save the partition size on the stack
3889                and increase the size each time we find we didn't swap, thus
3890                switching to insertion sort earlier for partitions with a
3891                history of not swapping).
3892
3893             4. Naturally, if I just switch right away, it will make
3894                artificial benchmarks with pure ascending (or descending)
3895                data look really good, but is that a good reason in general?
3896                Hard to say...
3897          */
3898
3899 #ifdef QSORT_ORDER_GUESS
3900          if (swapped < 3) {
3901 #if QSORT_ORDER_GUESS == 1
3902             qsort_break_even = (part_right - part_left) + 1;
3903 #endif
3904 #if QSORT_ORDER_GUESS == 2
3905             qsort_break_even *= 2;
3906 #endif
3907 #if QSORT_ORDER_GUESS == 3
3908             int prev_break = qsort_break_even;
3909             qsort_break_even *= qsort_break_even;
3910             if (qsort_break_even < prev_break) {
3911                qsort_break_even = (part_right - part_left) + 1;
3912             }
3913 #endif
3914          } else {
3915             qsort_break_even = QSORT_BREAK_EVEN;
3916          }
3917 #endif
3918
3919          if (part_left < pc_left) {
3920             /* There are elements on the left which need more processing.
3921                Check the right as well before deciding what to do.
3922             */
3923             if (pc_right < part_right) {
3924                /* We have two partitions to be sorted. Stack the biggest one
3925                   and process the smallest one on the next iteration. This
3926                   minimizes the stack height by insuring that any additional
3927                   stack entries must come from the smallest partition which
3928                   (because it is smallest) will have the fewest
3929                   opportunities to generate additional stack entries.
3930                */
3931                if ((part_right - pc_right) > (pc_left - part_left)) {
3932                   /* stack the right partition, process the left */
3933                   partition_stack[next_stack_entry].left = pc_right + 1;
3934                   partition_stack[next_stack_entry].right = part_right;
3935 #ifdef QSORT_ORDER_GUESS
3936                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3937 #endif
3938                   part_right = pc_left - 1;
3939                } else {
3940                   /* stack the left partition, process the right */
3941                   partition_stack[next_stack_entry].left = part_left;
3942                   partition_stack[next_stack_entry].right = pc_left - 1;
3943 #ifdef QSORT_ORDER_GUESS
3944                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3945 #endif
3946                   part_left = pc_right + 1;
3947                }
3948                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3949                ++next_stack_entry;
3950             } else {
3951                /* The elements on the left are the only remaining elements
3952                   that need sorting, arrange for them to be processed as the
3953                   next partition.
3954                */
3955                part_right = pc_left - 1;
3956             }
3957          } else if (pc_right < part_right) {
3958             /* There is only one chunk on the right to be sorted, make it
3959                the new partition and loop back around.
3960             */
3961             part_left = pc_right + 1;
3962          } else {
3963             /* This whole partition wound up in the pivot chunk, so
3964                we need to get a new partition off the stack.
3965             */
3966             if (next_stack_entry == 0) {
3967                /* the stack is empty - we are done */
3968                break;
3969             }
3970             --next_stack_entry;
3971             part_left = partition_stack[next_stack_entry].left;
3972             part_right = partition_stack[next_stack_entry].right;
3973 #ifdef QSORT_ORDER_GUESS
3974             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3975 #endif
3976          }
3977       } else {
3978          /* This partition is too small to fool with qsort complexity, just
3979             do an ordinary insertion sort to minimize overhead.
3980          */
3981          int i;
3982          /* Assume 1st element is in right place already, and start checking
3983             at 2nd element to see where it should be inserted.
3984          */
3985          for (i = part_left + 1; i <= part_right; ++i) {
3986             int j;
3987             /* Scan (backwards - just in case 'i' is already in right place)
3988                through the elements already sorted to see if the ith element
3989                belongs ahead of one of them.
3990             */
3991             for (j = i - 1; j >= part_left; --j) {
3992                if (qsort_cmp(i, j) >= 0) {
3993                   /* i belongs right after j
3994                   */
3995                   break;
3996                }
3997             }
3998             ++j;
3999             if (j != i) {
4000                /* Looks like we really need to move some things
4001                */
4002                int k;
4003                temp = array[i];
4004                for (k = i - 1; k >= j; --k)
4005                   array[k + 1] = array[k];
4006                array[j] = temp;
4007             }
4008          }
4009
4010          /* That partition is now sorted, grab the next one, or get out
4011             of the loop if there aren't any more.
4012          */
4013
4014          if (next_stack_entry == 0) {
4015             /* the stack is empty - we are done */
4016             break;
4017          }
4018          --next_stack_entry;
4019          part_left = partition_stack[next_stack_entry].left;
4020          part_right = partition_stack[next_stack_entry].right;
4021 #ifdef QSORT_ORDER_GUESS
4022          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4023 #endif
4024       }
4025    }
4026
4027    /* Believe it or not, the array is sorted at this point! */
4028 }