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