pp_ctl.c

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