pp_ctl.c

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