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 _((void *o));
  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 _((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, 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(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         } else {
2793             if (PerlLIO_stat(name, &pmstat) < 0 ||
2794                 pmstat.st_mtime < pmcstat.st_mtime) {
2795                 fp = PerlIO_open(pmc, mode);
2796           } else {
2797                 fp = PerlIO_open(name, mode);
2798           }
2799         }
2800         SvREFCNT_dec(pmcsv);
2801     } else {
2802         fp = PerlIO_open(name, mode);
2803     }
2804
2805     return fp;
2806 }
2807
2808 PP(pp_require)
2809 {
2810     djSP;
2811     register PERL_CONTEXT *cx;
2812     SV *sv;
2813     char *name;
2814     STRLEN len;
2815     char *tryname;
2816     SV *namesv = Nullsv;
2817     SV** svp;
2818     I32 gimme = G_SCALAR;
2819     PerlIO *tryrsfp = 0;
2820     STRLEN n_a;
2821
2822     sv = POPs;
2823     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2824         SET_NUMERIC_STANDARD();
2825         if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2826             DIE("Perl %s required--this is only version %s, stopped",
2827                 SvPV(sv,n_a),PL_patchlevel);
2828         RETPUSHYES;
2829     }
2830     name = SvPV(sv, len);
2831     if (!(name && len > 0 && *name))
2832         DIE("Null filename used");
2833     TAINT_PROPER("require");
2834     if (PL_op->op_type == OP_REQUIRE &&
2835       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2836       *svp != &PL_sv_undef)
2837         RETPUSHYES;
2838
2839     /* prepare to compile file */
2840
2841     if (*name == '/' ||
2842         (*name == '.' &&
2843             (name[1] == '/' ||
2844              (name[1] == '.' && name[2] == '/')))
2845 #ifdef DOSISH
2846       || (name[0] && name[1] == ':')
2847 #endif
2848 #ifdef WIN32
2849       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2850 #endif
2851 #ifdef VMS
2852         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2853             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2854 #endif
2855     )
2856     {
2857         tryname = name;
2858         tryrsfp = doopen(name,PERL_SCRIPT_MODE);
2859     }
2860     else {
2861         AV *ar = GvAVn(PL_incgv);
2862         I32 i;
2863 #ifdef VMS
2864         char *unixname;
2865         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2866 #endif
2867         {
2868             namesv = NEWSV(806, 0);
2869             for (i = 0; i <= AvFILL(ar); i++) {
2870                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2871 #ifdef VMS
2872                 char *unixdir;
2873                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2874                     continue;
2875                 sv_setpv(namesv, unixdir);
2876                 sv_catpv(namesv, unixname);
2877 #else
2878                 sv_setpvf(namesv, "%s/%s", dir, name);
2879 #endif
2880                 TAINT_PROPER("require");
2881                 tryname = SvPVX(namesv);
2882                 tryrsfp = doopen(tryname, PERL_SCRIPT_MODE);
2883                 if (tryrsfp) {
2884                     if (tryname[0] == '.' && tryname[1] == '/')
2885                         tryname += 2;
2886                     break;
2887                 }
2888             }
2889         }
2890     }
2891     SAVESPTR(PL_compiling.cop_filegv);
2892     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2893     SvREFCNT_dec(namesv);
2894     if (!tryrsfp) {
2895         if (PL_op->op_type == OP_REQUIRE) {
2896             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2897             SV *dirmsgsv = NEWSV(0, 0);
2898             AV *ar = GvAVn(PL_incgv);
2899             I32 i;
2900             if (instr(SvPVX(msg), ".h "))
2901                 sv_catpv(msg, " (change .h to .ph maybe?)");
2902             if (instr(SvPVX(msg), ".ph "))
2903                 sv_catpv(msg, " (did you run h2ph?)");
2904             sv_catpv(msg, " (@INC contains:");
2905             for (i = 0; i <= AvFILL(ar); i++) {
2906                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2907                 sv_setpvf(dirmsgsv, " %s", dir);
2908                 sv_catsv(msg, dirmsgsv);
2909             }
2910             sv_catpvn(msg, ")", 1);
2911             SvREFCNT_dec(dirmsgsv);
2912             DIE("%_", msg);
2913         }
2914
2915         RETPUSHUNDEF;
2916     }
2917     else
2918         SETERRNO(0, SS$_NORMAL);
2919
2920     /* Assume success here to prevent recursive requirement. */
2921     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2922         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2923
2924     ENTER;
2925     SAVETMPS;
2926     lex_start(sv_2mortal(newSVpvn("",0)));
2927     SAVEGENERICSV(PL_rsfp_filters);
2928     PL_rsfp_filters = Nullav;
2929
2930     PL_rsfp = tryrsfp;
2931     name = savepv(name);
2932     SAVEFREEPV(name);
2933     SAVEHINTS();
2934     PL_hints = 0;
2935     SAVEPPTR(PL_compiling.cop_warnings);
2936     PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2937                                                              : WARN_NONE);
2938
2939     /* switch to eval mode */
2940
2941     push_return(PL_op->op_next);
2942     PUSHBLOCK(cx, CXt_EVAL, SP);
2943     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2944
2945     SAVEI16(PL_compiling.cop_line);
2946     PL_compiling.cop_line = 0;
2947
2948     PUTBACK;
2949 #ifdef USE_THREADS
2950     MUTEX_LOCK(&PL_eval_mutex);
2951     if (PL_eval_owner && PL_eval_owner != thr)
2952         while (PL_eval_owner)
2953             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2954     PL_eval_owner = thr;
2955     MUTEX_UNLOCK(&PL_eval_mutex);
2956 #endif /* USE_THREADS */
2957     return DOCATCH(doeval(G_SCALAR, NULL));
2958 }
2959
2960 PP(pp_dofile)
2961 {
2962     return pp_require(ARGS);
2963 }
2964
2965 PP(pp_entereval)
2966 {
2967     djSP;
2968     register PERL_CONTEXT *cx;
2969     dPOPss;
2970     I32 gimme = GIMME_V, was = PL_sub_generation;
2971     char tmpbuf[TYPE_DIGITS(long) + 12];
2972     char *safestr;
2973     STRLEN len;
2974     OP *ret;
2975
2976     if (!SvPV(sv,len) || !len)
2977         RETPUSHUNDEF;
2978     TAINT_PROPER("eval");
2979
2980     ENTER;
2981     lex_start(sv);
2982     SAVETMPS;
2983
2984     /* switch to eval mode */
2985
2986     SAVESPTR(PL_compiling.cop_filegv);
2987     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2988     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2989     PL_compiling.cop_line = 1;
2990     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2991        deleting the eval's FILEGV from the stash before gv_check() runs
2992        (i.e. before run-time proper). To work around the coredump that
2993        ensues, we always turn GvMULTI_on for any globals that were
2994        introduced within evals. See force_ident(). GSAR 96-10-12 */
2995     safestr = savepv(tmpbuf);
2996     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2997     SAVEHINTS();
2998     PL_hints = PL_op->op_targ;
2999     SAVEPPTR(PL_compiling.cop_warnings);
3000     if (PL_compiling.cop_warnings != WARN_ALL
3001         && PL_compiling.cop_warnings != WARN_NONE){
3002         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3003         SAVEFREESV(PL_compiling.cop_warnings) ;
3004     }
3005
3006     push_return(PL_op->op_next);
3007     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3008     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3009
3010     /* prepare to compile string */
3011
3012     if (PERLDB_LINE && PL_curstash != PL_debstash)
3013         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3014     PUTBACK;
3015 #ifdef USE_THREADS
3016     MUTEX_LOCK(&PL_eval_mutex);
3017     if (PL_eval_owner && PL_eval_owner != thr)
3018         while (PL_eval_owner)
3019             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3020     PL_eval_owner = thr;
3021     MUTEX_UNLOCK(&PL_eval_mutex);
3022 #endif /* USE_THREADS */
3023     ret = doeval(gimme, NULL);
3024     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3025         && ret != PL_op->op_next) {     /* Successive compilation. */
3026         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3027     }
3028     return DOCATCH(ret);
3029 }
3030
3031 PP(pp_leaveeval)
3032 {
3033     djSP;
3034     register SV **mark;
3035     SV **newsp;
3036     PMOP *newpm;
3037     I32 gimme;
3038     register PERL_CONTEXT *cx;
3039     OP *retop;
3040     U8 save_flags = PL_op -> op_flags;
3041     I32 optype;
3042
3043     POPBLOCK(cx,newpm);
3044     POPEVAL(cx);
3045     retop = pop_return();
3046
3047     TAINT_NOT;
3048     if (gimme == G_VOID)
3049         MARK = newsp;
3050     else if (gimme == G_SCALAR) {
3051         MARK = newsp + 1;
3052         if (MARK <= SP) {
3053             if (SvFLAGS(TOPs) & SVs_TEMP)
3054                 *MARK = TOPs;
3055             else
3056                 *MARK = sv_mortalcopy(TOPs);
3057         }
3058         else {
3059             MEXTEND(mark,0);
3060             *MARK = &PL_sv_undef;
3061         }
3062     }
3063     else {
3064         /* in case LEAVE wipes old return values */
3065         for (mark = newsp + 1; mark <= SP; mark++) {
3066             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3067                 *mark = sv_mortalcopy(*mark);
3068                 TAINT_NOT;      /* Each item is independent */
3069             }
3070         }
3071     }
3072     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3073
3074     /*
3075      * Closures mentioned at top level of eval cannot be referenced
3076      * again, and their presence indirectly causes a memory leak.
3077      * (Note that the fact that compcv and friends are still set here
3078      * is, AFAIK, an accident.)  --Chip
3079      */
3080     if (AvFILLp(PL_comppad_name) >= 0) {
3081         SV **svp = AvARRAY(PL_comppad_name);
3082         I32 ix;
3083         for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
3084             SV *sv = svp[ix];
3085             if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
3086                 SvREFCNT_dec(sv);
3087                 svp[ix] = &PL_sv_undef;
3088
3089                 sv = PL_curpad[ix];
3090                 if (CvCLONE(sv)) {
3091                     SvREFCNT_dec(CvOUTSIDE(sv));
3092                     CvOUTSIDE(sv) = Nullcv;
3093                 }
3094                 else {
3095                     SvREFCNT_dec(sv);
3096                     sv = NEWSV(0,0);
3097                     SvPADTMP_on(sv);
3098                     PL_curpad[ix] = sv;
3099                 }
3100             }
3101         }
3102     }
3103
3104 #ifdef DEBUGGING
3105     assert(CvDEPTH(PL_compcv) == 1);
3106 #endif
3107     CvDEPTH(PL_compcv) = 0;
3108     lex_end();
3109
3110     if (optype == OP_REQUIRE &&
3111         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3112     {
3113         /* Unassume the success we assumed earlier. */
3114         char *name = cx->blk_eval.old_name;
3115         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3116         retop = die("%s did not return a true value", name);
3117         /* die_where() did LEAVE, or we won't be here */
3118     }
3119     else {
3120         LEAVE;
3121         if (!(save_flags & OPf_SPECIAL))
3122             sv_setpv(ERRSV,"");
3123     }
3124
3125     RETURNOP(retop);
3126 }
3127
3128 PP(pp_entertry)
3129 {
3130     djSP;
3131     register PERL_CONTEXT *cx;
3132     I32 gimme = GIMME_V;
3133
3134     ENTER;
3135     SAVETMPS;
3136
3137     push_return(cLOGOP->op_other->op_next);
3138     PUSHBLOCK(cx, CXt_EVAL, SP);
3139     PUSHEVAL(cx, 0, 0);
3140     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3141
3142     PL_in_eval = 1;
3143     sv_setpv(ERRSV,"");
3144     PUTBACK;
3145     return DOCATCH(PL_op->op_next);
3146 }
3147
3148 PP(pp_leavetry)
3149 {
3150     djSP;
3151     register SV **mark;
3152     SV **newsp;
3153     PMOP *newpm;
3154     I32 gimme;
3155     register PERL_CONTEXT *cx;
3156     I32 optype;
3157
3158     POPBLOCK(cx,newpm);
3159     POPEVAL(cx);
3160     pop_return();
3161
3162     TAINT_NOT;
3163     if (gimme == G_VOID)
3164         SP = newsp;
3165     else if (gimme == G_SCALAR) {
3166         MARK = newsp + 1;
3167         if (MARK <= SP) {
3168             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3169                 *MARK = TOPs;
3170             else
3171                 *MARK = sv_mortalcopy(TOPs);
3172         }
3173         else {
3174             MEXTEND(mark,0);
3175             *MARK = &PL_sv_undef;
3176         }
3177         SP = MARK;
3178     }
3179     else {
3180         /* in case LEAVE wipes old return values */
3181         for (mark = newsp + 1; mark <= SP; mark++) {
3182             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3183                 *mark = sv_mortalcopy(*mark);
3184                 TAINT_NOT;      /* Each item is independent */
3185             }
3186         }
3187     }
3188     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3189
3190     LEAVE;
3191     sv_setpv(ERRSV,"");
3192     RETURN;
3193 }
3194
3195 STATIC void
3196 doparseform(SV *sv)
3197 {
3198     STRLEN len;
3199     register char *s = SvPV_force(sv, len);
3200     register char *send = s + len;
3201     register char *base;
3202     register I32 skipspaces = 0;
3203     bool noblank;
3204     bool repeat;
3205     bool postspace = FALSE;
3206     U16 *fops;
3207     register U16 *fpc;
3208     U16 *linepc;
3209     register I32 arg;
3210     bool ischop;
3211
3212     if (len == 0)
3213         croak("Null picture in formline");
3214
3215     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3216     fpc = fops;
3217
3218     if (s < send) {
3219         linepc = fpc;
3220         *fpc++ = FF_LINEMARK;
3221         noblank = repeat = FALSE;
3222         base = s;
3223     }
3224
3225     while (s <= send) {
3226         switch (*s++) {
3227         default:
3228             skipspaces = 0;
3229             continue;
3230
3231         case '~':
3232             if (*s == '~') {
3233                 repeat = TRUE;
3234                 *s = ' ';
3235             }
3236             noblank = TRUE;
3237             s[-1] = ' ';
3238             /* FALL THROUGH */
3239         case ' ': case '\t':
3240             skipspaces++;
3241             continue;
3242
3243         case '\n': case 0:
3244             arg = s - base;
3245             skipspaces++;
3246             arg -= skipspaces;
3247             if (arg) {
3248                 if (postspace)
3249                     *fpc++ = FF_SPACE;
3250                 *fpc++ = FF_LITERAL;
3251                 *fpc++ = arg;
3252             }
3253             postspace = FALSE;
3254             if (s <= send)
3255                 skipspaces--;
3256             if (skipspaces) {
3257                 *fpc++ = FF_SKIP;
3258                 *fpc++ = skipspaces;
3259             }
3260             skipspaces = 0;
3261             if (s <= send)
3262                 *fpc++ = FF_NEWLINE;
3263             if (noblank) {
3264                 *fpc++ = FF_BLANK;
3265                 if (repeat)
3266                     arg = fpc - linepc + 1;
3267                 else
3268                     arg = 0;
3269                 *fpc++ = arg;
3270             }
3271             if (s < send) {
3272                 linepc = fpc;
3273                 *fpc++ = FF_LINEMARK;
3274                 noblank = repeat = FALSE;
3275                 base = s;
3276             }
3277             else
3278                 s++;
3279             continue;
3280
3281         case '@':
3282         case '^':
3283             ischop = s[-1] == '^';
3284
3285             if (postspace) {
3286                 *fpc++ = FF_SPACE;
3287                 postspace = FALSE;
3288             }
3289             arg = (s - base) - 1;
3290             if (arg) {
3291                 *fpc++ = FF_LITERAL;
3292                 *fpc++ = arg;
3293             }
3294
3295             base = s - 1;
3296             *fpc++ = FF_FETCH;
3297             if (*s == '*') {
3298                 s++;
3299                 *fpc++ = 0;
3300                 *fpc++ = FF_LINEGLOB;
3301             }
3302             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3303                 arg = ischop ? 512 : 0;
3304                 base = s - 1;
3305                 while (*s == '#')
3306                     s++;
3307                 if (*s == '.') {
3308                     char *f;
3309                     s++;
3310                     f = s;
3311                     while (*s == '#')
3312                         s++;
3313                     arg |= 256 + (s - f);
3314                 }
3315                 *fpc++ = s - base;              /* fieldsize for FETCH */
3316                 *fpc++ = FF_DECIMAL;
3317                 *fpc++ = arg;
3318             }
3319             else {
3320                 I32 prespace = 0;
3321                 bool ismore = FALSE;
3322
3323                 if (*s == '>') {
3324                     while (*++s == '>') ;
3325                     prespace = FF_SPACE;
3326                 }
3327                 else if (*s == '|') {
3328                     while (*++s == '|') ;
3329                     prespace = FF_HALFSPACE;
3330                     postspace = TRUE;
3331                 }
3332                 else {
3333                     if (*s == '<')
3334                         while (*++s == '<') ;
3335                     postspace = TRUE;
3336                 }
3337                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3338                     s += 3;
3339                     ismore = TRUE;
3340                 }
3341                 *fpc++ = s - base;              /* fieldsize for FETCH */
3342
3343                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3344
3345                 if (prespace)
3346                     *fpc++ = prespace;
3347                 *fpc++ = FF_ITEM;
3348                 if (ismore)
3349                     *fpc++ = FF_MORE;
3350                 if (ischop)
3351                     *fpc++ = FF_CHOP;
3352             }
3353             base = s;
3354             skipspaces = 0;
3355             continue;
3356         }
3357     }
3358     *fpc++ = FF_END;
3359
3360     arg = fpc - fops;
3361     { /* need to jump to the next word */
3362         int z;
3363         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3364         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3365         s = SvPVX(sv) + SvCUR(sv) + z;
3366     }
3367     Copy(fops, s, arg, U16);
3368     Safefree(fops);
3369     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3370     SvCOMPILED_on(sv);
3371 }
3372
3373 /*
3374  * The rest of this file was derived from source code contributed
3375  * by Tom Horsley.
3376  *
3377  * NOTE: this code was derived from Tom Horsley's qsort replacement
3378  * and should not be confused with the original code.
3379  */
3380
3381 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3382
3383    Permission granted to distribute under the same terms as perl which are
3384    (briefly):
3385
3386     This program is free software; you can redistribute it and/or modify
3387     it under the terms of either:
3388
3389         a) the GNU General Public License as published by the Free
3390         Software Foundation; either version 1, or (at your option) any
3391         later version, or
3392
3393         b) the "Artistic License" which comes with this Kit.
3394
3395    Details on the perl license can be found in the perl source code which
3396    may be located via the www.perl.com web page.
3397
3398    This is the most wonderfulest possible qsort I can come up with (and
3399    still be mostly portable) My (limited) tests indicate it consistently
3400    does about 20% fewer calls to compare than does the qsort in the Visual
3401    C++ library, other vendors may vary.
3402
3403    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3404    others I invented myself (or more likely re-invented since they seemed
3405    pretty obvious once I watched the algorithm operate for a while).
3406
3407    Most of this code was written while watching the Marlins sweep the Giants
3408    in the 1997 National League Playoffs - no Braves fans allowed to use this
3409    code (just kidding :-).
3410
3411    I realize that if I wanted to be true to the perl tradition, the only
3412    comment in this file would be something like:
3413
3414    ...they shuffled back towards the rear of the line. 'No, not at the
3415    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3416
3417    However, I really needed to violate that tradition just so I could keep
3418    track of what happens myself, not to mention some poor fool trying to
3419    understand this years from now :-).
3420 */
3421
3422 /* ********************************************************** Configuration */
3423
3424 #ifndef QSORT_ORDER_GUESS
3425 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3426 #endif
3427
3428 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3429    future processing - a good max upper bound is log base 2 of memory size
3430    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3431    safely be smaller than that since the program is taking up some space and
3432    most operating systems only let you grab some subset of contiguous
3433    memory (not to mention that you are normally sorting data larger than
3434    1 byte element size :-).
3435 */
3436 #ifndef QSORT_MAX_STACK
3437 #define QSORT_MAX_STACK 32
3438 #endif
3439
3440 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3441    Anything bigger and we use qsort. If you make this too small, the qsort
3442    will probably break (or become less efficient), because it doesn't expect
3443    the middle element of a partition to be the same as the right or left -
3444    you have been warned).
3445 */
3446 #ifndef QSORT_BREAK_EVEN
3447 #define QSORT_BREAK_EVEN 6
3448 #endif
3449
3450 /* ************************************************************* Data Types */
3451
3452 /* hold left and right index values of a partition waiting to be sorted (the
3453    partition includes both left and right - right is NOT one past the end or
3454    anything like that).
3455 */
3456 struct partition_stack_entry {
3457    int left;
3458    int right;
3459 #ifdef QSORT_ORDER_GUESS
3460    int qsort_break_even;
3461 #endif
3462 };
3463
3464 /* ******************************************************* Shorthand Macros */
3465
3466 /* Note that these macros will be used from inside the qsort function where
3467    we happen to know that the variable 'elt_size' contains the size of an
3468    array element and the variable 'temp' points to enough space to hold a
3469    temp element and the variable 'array' points to the array being sorted
3470    and 'compare' is the pointer to the compare routine.
3471
3472    Also note that there are very many highly architecture specific ways
3473    these might be sped up, but this is simply the most generally portable
3474    code I could think of.
3475 */
3476
3477 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3478 */
3479 #ifdef PERL_OBJECT
3480 #define qsort_cmp(elt1, elt2) \
3481    ((this->*compare)(array[elt1], array[elt2]))
3482 #else
3483 #define qsort_cmp(elt1, elt2) \
3484    ((*compare)(array[elt1], array[elt2]))
3485 #endif
3486
3487 #ifdef QSORT_ORDER_GUESS
3488 #define QSORT_NOTICE_SWAP swapped++;
3489 #else
3490 #define QSORT_NOTICE_SWAP
3491 #endif
3492
3493 /* swaps contents of array elements elt1, elt2.
3494 */
3495 #define qsort_swap(elt1, elt2) \
3496    STMT_START { \
3497       QSORT_NOTICE_SWAP \
3498       temp = array[elt1]; \
3499       array[elt1] = array[elt2]; \
3500       array[elt2] = temp; \
3501    } STMT_END
3502
3503 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3504    elt3 and elt3 gets elt1.
3505 */
3506 #define qsort_rotate(elt1, elt2, elt3) \
3507    STMT_START { \
3508       QSORT_NOTICE_SWAP \
3509       temp = array[elt1]; \
3510       array[elt1] = array[elt2]; \
3511       array[elt2] = array[elt3]; \
3512       array[elt3] = temp; \
3513    } STMT_END
3514
3515 /* ************************************************************ Debug stuff */
3516
3517 #ifdef QSORT_DEBUG
3518
3519 static void
3520 break_here()
3521 {
3522    return; /* good place to set a breakpoint */
3523 }
3524
3525 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3526
3527 static void
3528 doqsort_all_asserts(
3529    void * array,
3530    size_t num_elts,
3531    size_t elt_size,
3532    int (*compare)(const void * elt1, const void * elt2),
3533    int pc_left, int pc_right, int u_left, int u_right)
3534 {
3535    int i;
3536
3537    qsort_assert(pc_left <= pc_right);
3538    qsort_assert(u_right < pc_left);
3539    qsort_assert(pc_right < u_left);
3540    for (i = u_right + 1; i < pc_left; ++i) {
3541       qsort_assert(qsort_cmp(i, pc_left) < 0);
3542    }
3543    for (i = pc_left; i < pc_right; ++i) {
3544       qsort_assert(qsort_cmp(i, pc_right) == 0);
3545    }
3546    for (i = pc_right + 1; i < u_left; ++i) {
3547       qsort_assert(qsort_cmp(pc_right, i) < 0);
3548    }
3549 }
3550
3551 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3552    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3553                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3554
3555 #else
3556
3557 #define qsort_assert(t) ((void)0)
3558
3559 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3560
3561 #endif
3562
3563 /* ****************************************************************** qsort */
3564
3565 STATIC void
3566 #ifdef PERL_OBJECT
3567 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3568 #else
3569 qsortsv(
3570    SV ** array,
3571    size_t num_elts,
3572    I32 (*compare)(SV *a, SV *b))
3573 #endif
3574 {
3575    register SV * temp;
3576
3577    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3578    int next_stack_entry = 0;
3579
3580    int part_left;
3581    int part_right;
3582 #ifdef QSORT_ORDER_GUESS
3583    int qsort_break_even;
3584    int swapped;
3585 #endif
3586
3587    /* Make sure we actually have work to do.
3588    */
3589    if (num_elts <= 1) {
3590       return;
3591    }
3592
3593    /* Setup the initial partition definition and fall into the sorting loop
3594    */
3595    part_left = 0;
3596    part_right = (int)(num_elts - 1);
3597 #ifdef QSORT_ORDER_GUESS
3598    qsort_break_even = QSORT_BREAK_EVEN;
3599 #else
3600 #define qsort_break_even QSORT_BREAK_EVEN
3601 #endif
3602    for ( ; ; ) {
3603       if ((part_right - part_left) >= qsort_break_even) {
3604          /* OK, this is gonna get hairy, so lets try to document all the
3605             concepts and abbreviations and variables and what they keep
3606             track of:
3607
3608             pc: pivot chunk - the set of array elements we accumulate in the
3609                 middle of the partition, all equal in value to the original
3610                 pivot element selected. The pc is defined by:
3611
3612                 pc_left - the leftmost array index of the pc
3613                 pc_right - the rightmost array index of the pc
3614
3615                 we start with pc_left == pc_right and only one element
3616                 in the pivot chunk (but it can grow during the scan).
3617
3618             u:  uncompared elements - the set of elements in the partition
3619                 we have not yet compared to the pivot value. There are two
3620                 uncompared sets during the scan - one to the left of the pc
3621                 and one to the right.
3622
3623                 u_right - the rightmost index of the left side's uncompared set
3624                 u_left - the leftmost index of the right side's uncompared set
3625
3626                 The leftmost index of the left sides's uncompared set
3627                 doesn't need its own variable because it is always defined
3628                 by the leftmost edge of the whole partition (part_left). The
3629                 same goes for the rightmost edge of the right partition
3630                 (part_right).
3631
3632                 We know there are no uncompared elements on the left once we
3633                 get u_right < part_left and no uncompared elements on the
3634                 right once u_left > part_right. When both these conditions
3635                 are met, we have completed the scan of the partition.
3636
3637                 Any elements which are between the pivot chunk and the
3638                 uncompared elements should be less than the pivot value on
3639                 the left side and greater than the pivot value on the right
3640                 side (in fact, the goal of the whole algorithm is to arrange
3641                 for that to be true and make the groups of less-than and
3642                 greater-then elements into new partitions to sort again).
3643
3644             As you marvel at the complexity of the code and wonder why it
3645             has to be so confusing. Consider some of the things this level
3646             of confusion brings:
3647
3648             Once I do a compare, I squeeze every ounce of juice out of it. I
3649             never do compare calls I don't have to do, and I certainly never
3650             do redundant calls.
3651
3652             I also never swap any elements unless I can prove there is a
3653             good reason. Many sort algorithms will swap a known value with
3654             an uncompared value just to get things in the right place (or
3655             avoid complexity :-), but that uncompared value, once it gets
3656             compared, may then have to be swapped again. A lot of the
3657             complexity of this code is due to the fact that it never swaps
3658             anything except compared values, and it only swaps them when the
3659             compare shows they are out of position.
3660          */
3661          int pc_left, pc_right;
3662          int u_right, u_left;
3663
3664          int s;
3665
3666          pc_left = ((part_left + part_right) / 2);
3667          pc_right = pc_left;
3668          u_right = pc_left - 1;
3669          u_left = pc_right + 1;
3670
3671          /* Qsort works best when the pivot value is also the median value
3672             in the partition (unfortunately you can't find the median value
3673             without first sorting :-), so to give the algorithm a helping
3674             hand, we pick 3 elements and sort them and use the median value
3675             of that tiny set as the pivot value.
3676
3677             Some versions of qsort like to use the left middle and right as
3678             the 3 elements to sort so they can insure the ends of the
3679             partition will contain values which will stop the scan in the
3680             compare loop, but when you have to call an arbitrarily complex
3681             routine to do a compare, its really better to just keep track of
3682             array index values to know when you hit the edge of the
3683             partition and avoid the extra compare. An even better reason to
3684             avoid using a compare call is the fact that you can drop off the
3685             edge of the array if someone foolishly provides you with an
3686             unstable compare function that doesn't always provide consistent
3687             results.
3688
3689             So, since it is simpler for us to compare the three adjacent
3690             elements in the middle of the partition, those are the ones we
3691             pick here (conveniently pointed at by u_right, pc_left, and
3692             u_left). The values of the left, center, and right elements
3693             are refered to as l c and r in the following comments.
3694          */
3695
3696 #ifdef QSORT_ORDER_GUESS
3697          swapped = 0;
3698 #endif
3699          s = qsort_cmp(u_right, pc_left);
3700          if (s < 0) {
3701             /* l < c */
3702             s = qsort_cmp(pc_left, u_left);
3703             /* if l < c, c < r - already in order - nothing to do */
3704             if (s == 0) {
3705                /* l < c, c == r - already in order, pc grows */
3706                ++pc_right;
3707                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3708             } else if (s > 0) {
3709                /* l < c, c > r - need to know more */
3710                s = qsort_cmp(u_right, u_left);
3711                if (s < 0) {
3712                   /* l < c, c > r, l < r - swap c & r to get ordered */
3713                   qsort_swap(pc_left, u_left);
3714                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3715                } else if (s == 0) {
3716                   /* l < c, c > r, l == r - swap c&r, grow pc */
3717                   qsort_swap(pc_left, u_left);
3718                   --pc_left;
3719                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3720                } else {
3721                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3722                   qsort_rotate(pc_left, u_right, u_left);
3723                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3724                }
3725             }
3726          } else if (s == 0) {
3727             /* l == c */
3728             s = qsort_cmp(pc_left, u_left);
3729             if (s < 0) {
3730                /* l == c, c < r - already in order, grow pc */
3731                --pc_left;
3732                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3733             } else if (s == 0) {
3734                /* l == c, c == r - already in order, grow pc both ways */
3735                --pc_left;
3736                ++pc_right;
3737                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3738             } else {
3739                /* l == c, c > r - swap l & r, grow pc */
3740                qsort_swap(u_right, u_left);
3741                ++pc_right;
3742                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3743             }
3744          } else {
3745             /* l > c */
3746             s = qsort_cmp(pc_left, u_left);
3747             if (s < 0) {
3748                /* l > c, c < r - need to know more */
3749                s = qsort_cmp(u_right, u_left);
3750                if (s < 0) {
3751                   /* l > c, c < r, l < r - swap l & c to get ordered */
3752                   qsort_swap(u_right, pc_left);
3753                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3754                } else if (s == 0) {
3755                   /* l > c, c < r, l == r - swap l & c, grow pc */
3756                   qsort_swap(u_right, pc_left);
3757                   ++pc_right;
3758                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3759                } else {
3760                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3761                   qsort_rotate(u_right, pc_left, u_left);
3762                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3763                }
3764             } else if (s == 0) {
3765                /* l > c, c == r - swap ends, grow pc */
3766                qsort_swap(u_right, u_left);
3767                --pc_left;
3768                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3769             } else {
3770                /* l > c, c > r - swap ends to get in order */
3771                qsort_swap(u_right, u_left);
3772                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3773             }
3774          }
3775          /* We now know the 3 middle elements have been compared and
3776             arranged in the desired order, so we can shrink the uncompared
3777             sets on both sides
3778          */
3779          --u_right;
3780          ++u_left;
3781          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3782
3783          /* The above massive nested if was the simple part :-). We now have
3784             the middle 3 elements ordered and we need to scan through the
3785             uncompared sets on either side, swapping elements that are on
3786             the wrong side or simply shuffling equal elements around to get
3787             all equal elements into the pivot chunk.
3788          */
3789
3790          for ( ; ; ) {
3791             int still_work_on_left;
3792             int still_work_on_right;
3793
3794             /* Scan the uncompared values on the left. If I find a value
3795                equal to the pivot value, move it over so it is adjacent to
3796                the pivot chunk and expand the pivot chunk. If I find a value
3797                less than the pivot value, then just leave it - its already
3798                on the correct side of the partition. If I find a greater
3799                value, then stop the scan.
3800             */
3801             while (still_work_on_left = (u_right >= part_left)) {
3802                s = qsort_cmp(u_right, pc_left);
3803                if (s < 0) {
3804                   --u_right;
3805                } else if (s == 0) {
3806                   --pc_left;
3807                   if (pc_left != u_right) {
3808                      qsort_swap(u_right, pc_left);
3809                   }
3810                   --u_right;
3811                } else {
3812                   break;
3813                }
3814                qsort_assert(u_right < pc_left);
3815                qsort_assert(pc_left <= pc_right);
3816                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3817                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3818             }
3819
3820             /* Do a mirror image scan of uncompared values on the right
3821             */
3822             while (still_work_on_right = (u_left <= part_right)) {
3823                s = qsort_cmp(pc_right, u_left);
3824                if (s < 0) {
3825                   ++u_left;
3826                } else if (s == 0) {
3827                   ++pc_right;
3828                   if (pc_right != u_left) {
3829                      qsort_swap(pc_right, u_left);
3830                   }
3831                   ++u_left;
3832                } else {
3833                   break;
3834                }
3835                qsort_assert(u_left > pc_right);
3836                qsort_assert(pc_left <= pc_right);
3837                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3838                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3839             }
3840
3841             if (still_work_on_left) {
3842                /* I know I have a value on the left side which needs to be
3843                   on the right side, but I need to know more to decide
3844                   exactly the best thing to do with it.
3845                */
3846                if (still_work_on_right) {
3847                   /* I know I have values on both side which are out of
3848                      position. This is a big win because I kill two birds
3849                      with one swap (so to speak). I can advance the
3850                      uncompared pointers on both sides after swapping both
3851                      of them into the right place.
3852                   */
3853                   qsort_swap(u_right, u_left);
3854                   --u_right;
3855                   ++u_left;
3856                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3857                } else {
3858                   /* I have an out of position value on the left, but the
3859                      right is fully scanned, so I "slide" the pivot chunk
3860                      and any less-than values left one to make room for the
3861                      greater value over on the right. If the out of position
3862                      value is immediately adjacent to the pivot chunk (there
3863                      are no less-than values), I can do that with a swap,
3864                      otherwise, I have to rotate one of the less than values
3865                      into the former position of the out of position value
3866                      and the right end of the pivot chunk into the left end
3867                      (got all that?).
3868                   */
3869                   --pc_left;
3870                   if (pc_left == u_right) {
3871                      qsort_swap(u_right, pc_right);
3872                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3873                   } else {
3874                      qsort_rotate(u_right, pc_left, pc_right);
3875                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3876                   }
3877                   --pc_right;
3878                   --u_right;
3879                }
3880             } else if (still_work_on_right) {
3881                /* Mirror image of complex case above: I have an out of
3882                   position value on the right, but the left is fully
3883                   scanned, so I need to shuffle things around to make room
3884                   for the right value on the left.
3885                */
3886                ++pc_right;
3887                if (pc_right == u_left) {
3888                   qsort_swap(u_left, pc_left);
3889                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3890                } else {
3891                   qsort_rotate(pc_right, pc_left, u_left);
3892                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3893                }
3894                ++pc_left;
3895                ++u_left;
3896             } else {
3897                /* No more scanning required on either side of partition,
3898                   break out of loop and figure out next set of partitions
3899                */
3900                break;
3901             }
3902          }
3903
3904          /* The elements in the pivot chunk are now in the right place. They
3905             will never move or be compared again. All I have to do is decide
3906             what to do with the stuff to the left and right of the pivot
3907             chunk.
3908
3909             Notes on the QSORT_ORDER_GUESS ifdef code:
3910
3911             1. If I just built these partitions without swapping any (or
3912                very many) elements, there is a chance that the elements are
3913                already ordered properly (being properly ordered will
3914                certainly result in no swapping, but the converse can't be
3915                proved :-).
3916
3917             2. A (properly written) insertion sort will run faster on
3918                already ordered data than qsort will.
3919
3920             3. Perhaps there is some way to make a good guess about
3921                switching to an insertion sort earlier than partition size 6
3922                (for instance - we could save the partition size on the stack
3923                and increase the size each time we find we didn't swap, thus
3924                switching to insertion sort earlier for partitions with a
3925                history of not swapping).
3926
3927             4. Naturally, if I just switch right away, it will make
3928                artificial benchmarks with pure ascending (or descending)
3929                data look really good, but is that a good reason in general?
3930                Hard to say...
3931          */
3932
3933 #ifdef QSORT_ORDER_GUESS
3934          if (swapped < 3) {
3935 #if QSORT_ORDER_GUESS == 1
3936             qsort_break_even = (part_right - part_left) + 1;
3937 #endif
3938 #if QSORT_ORDER_GUESS == 2
3939             qsort_break_even *= 2;
3940 #endif
3941 #if QSORT_ORDER_GUESS == 3
3942             int prev_break = qsort_break_even;
3943             qsort_break_even *= qsort_break_even;
3944             if (qsort_break_even < prev_break) {
3945                qsort_break_even = (part_right - part_left) + 1;
3946             }
3947 #endif
3948          } else {
3949             qsort_break_even = QSORT_BREAK_EVEN;
3950          }
3951 #endif
3952
3953          if (part_left < pc_left) {
3954             /* There are elements on the left which need more processing.
3955                Check the right as well before deciding what to do.
3956             */
3957             if (pc_right < part_right) {
3958                /* We have two partitions to be sorted. Stack the biggest one
3959                   and process the smallest one on the next iteration. This
3960                   minimizes the stack height by insuring that any additional
3961                   stack entries must come from the smallest partition which
3962                   (because it is smallest) will have the fewest
3963                   opportunities to generate additional stack entries.
3964                */
3965                if ((part_right - pc_right) > (pc_left - part_left)) {
3966                   /* stack the right partition, process the left */
3967                   partition_stack[next_stack_entry].left = pc_right + 1;
3968                   partition_stack[next_stack_entry].right = part_right;
3969 #ifdef QSORT_ORDER_GUESS
3970                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3971 #endif
3972                   part_right = pc_left - 1;
3973                } else {
3974                   /* stack the left partition, process the right */
3975                   partition_stack[next_stack_entry].left = part_left;
3976                   partition_stack[next_stack_entry].right = pc_left - 1;
3977 #ifdef QSORT_ORDER_GUESS
3978                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3979 #endif
3980                   part_left = pc_right + 1;
3981                }
3982                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3983                ++next_stack_entry;
3984             } else {
3985                /* The elements on the left are the only remaining elements
3986                   that need sorting, arrange for them to be processed as the
3987                   next partition.
3988                */
3989                part_right = pc_left - 1;
3990             }
3991          } else if (pc_right < part_right) {
3992             /* There is only one chunk on the right to be sorted, make it
3993                the new partition and loop back around.
3994             */
3995             part_left = pc_right + 1;
3996          } else {
3997             /* This whole partition wound up in the pivot chunk, so
3998                we need to get a new partition off the stack.
3999             */
4000             if (next_stack_entry == 0) {
4001                /* the stack is empty - we are done */
4002                break;
4003             }
4004             --next_stack_entry;
4005             part_left = partition_stack[next_stack_entry].left;
4006             part_right = partition_stack[next_stack_entry].right;
4007 #ifdef QSORT_ORDER_GUESS
4008             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4009 #endif
4010          }
4011       } else {
4012          /* This partition is too small to fool with qsort complexity, just
4013             do an ordinary insertion sort to minimize overhead.
4014          */
4015          int i;
4016          /* Assume 1st element is in right place already, and start checking
4017             at 2nd element to see where it should be inserted.
4018          */
4019          for (i = part_left + 1; i <= part_right; ++i) {
4020             int j;
4021             /* Scan (backwards - just in case 'i' is already in right place)
4022                through the elements already sorted to see if the ith element
4023                belongs ahead of one of them.
4024             */
4025             for (j = i - 1; j >= part_left; --j) {
4026                if (qsort_cmp(i, j) >= 0) {
4027                   /* i belongs right after j
4028                   */
4029                   break;
4030                }
4031             }
4032             ++j;
4033             if (j != i) {
4034                /* Looks like we really need to move some things
4035                */
4036                int k;
4037                temp = array[i];
4038                for (k = i - 1; k >= j; --k)
4039                   array[k + 1] = array[k];
4040                array[j] = temp;
4041             }
4042          }
4043
4044          /* That partition is now sorted, grab the next one, or get out
4045             of the loop if there aren't any more.
4046          */
4047
4048          if (next_stack_entry == 0) {
4049             /* the stack is empty - we are done */
4050             break;
4051          }
4052          --next_stack_entry;
4053          part_left = partition_stack[next_stack_entry].left;
4054          part_right = partition_stack[next_stack_entry].right;
4055 #ifdef QSORT_ORDER_GUESS
4056          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4057 #endif
4058       }
4059    }
4060
4061    /* Believe it or not, the array is sorted at this point! */
4062 }