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