pp_ctl.c

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