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 (ckWARN(WARN_SYNTAX))
 361                     warner(WARN_SYNTAX, "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 (CxTYPE(cx)) {
 981         case CXt_SUBST:
 982             if (ckWARN(WARN_UNSAFE))
 983                 warner(WARN_UNSAFE, "Exiting substitution via %s",
 984                         op_name[PL_op->op_type]);
 985             break;
 986         case CXt_SUB:
 987             if (ckWARN(WARN_UNSAFE))
 988                 warner(WARN_UNSAFE, "Exiting subroutine via %s",
 989                         op_name[PL_op->op_type]);
 990             break;
 991         case CXt_EVAL:
 992             if (ckWARN(WARN_UNSAFE))
 993                 warner(WARN_UNSAFE, "Exiting eval via %s",
 994                         op_name[PL_op->op_type]);
 995             break;
 996         case CXt_NULL:
 997             if (ckWARN(WARN_UNSAFE))
 998                 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
 999                         op_name[PL_op->op_type]);
1000             return -1;
1001         case CXt_LOOP:
1002             if (!cx->blk_loop.label ||
1003               strNE(label, cx->blk_loop.label) ) {
1004                 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1005                         (long)i, cx->blk_loop.label));
1006                 continue;
1007             }
1008             DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1009             return i;
1010         }
1011     }
1012     return i;
1013 }
1014
1015 I32
1016 dowantarray(void)
1017 {
1018     I32 gimme = block_gimme();
1019     return (gimme == G_VOID) ? G_SCALAR : gimme;
1020 }
1021
1022 I32
1023 block_gimme(void)
1024 {
1025     dTHR;
1026     I32 cxix;
1027
1028     cxix = dopoptosub(cxstack_ix);
1029     if (cxix < 0)
1030         return G_VOID;
1031
1032     switch (cxstack[cxix].blk_gimme) {
1033     case G_VOID:
1034         return G_VOID;
1035     case G_SCALAR:
1036         return G_SCALAR;
1037     case G_ARRAY:
1038         return G_ARRAY;
1039     default:
1040         croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1041         /* NOTREACHED */
1042         return 0;
1043     }
1044 }
1045
1046 STATIC I32
1047 dopoptosub(I32 startingblock)
1048 {
1049     dTHR;
1050     return dopoptosub_at(cxstack, startingblock);
1051 }
1052
1053 STATIC I32
1054 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1055 {
1056     dTHR;
1057     I32 i;
1058     register PERL_CONTEXT *cx;
1059     for (i = startingblock; i >= 0; i--) {
1060         cx = &cxstk[i];
1061         switch (CxTYPE(cx)) {
1062         default:
1063             continue;
1064         case CXt_EVAL:
1065         case CXt_SUB:
1066             DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1067             return i;
1068         }
1069     }
1070     return i;
1071 }
1072
1073 STATIC I32
1074 dopoptoeval(I32 startingblock)
1075 {
1076     dTHR;
1077     I32 i;
1078     register PERL_CONTEXT *cx;
1079     for (i = startingblock; i >= 0; i--) {
1080         cx = &cxstack[i];
1081         switch (CxTYPE(cx)) {
1082         default:
1083             continue;
1084         case CXt_EVAL:
1085             DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1086             return i;
1087         }
1088     }
1089     return i;
1090 }
1091
1092 STATIC I32
1093 dopoptoloop(I32 startingblock)
1094 {
1095     dTHR;
1096     I32 i;
1097     register PERL_CONTEXT *cx;
1098     for (i = startingblock; i >= 0; i--) {
1099         cx = &cxstack[i];
1100         switch (CxTYPE(cx)) {
1101         case CXt_SUBST:
1102             if (ckWARN(WARN_UNSAFE))
1103                 warner(WARN_UNSAFE, "Exiting substitution via %s",
1104                         op_name[PL_op->op_type]);
1105             break;
1106         case CXt_SUB:
1107             if (ckWARN(WARN_UNSAFE))
1108                 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1109                         op_name[PL_op->op_type]);
1110             break;
1111         case CXt_EVAL:
1112             if (ckWARN(WARN_UNSAFE))
1113                 warner(WARN_UNSAFE, "Exiting eval via %s",
1114                         op_name[PL_op->op_type]);
1115             break;
1116         case CXt_NULL:
1117             if (ckWARN(WARN_UNSAFE))
1118                 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1119                         op_name[PL_op->op_type]);
1120             return -1;
1121         case CXt_LOOP:
1122             DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1123             return i;
1124         }
1125     }
1126     return i;
1127 }
1128
1129 void
1130 dounwind(I32 cxix)
1131 {
1132     dTHR;
1133     register PERL_CONTEXT *cx;
1134     SV **newsp;
1135     I32 optype;
1136
1137     while (cxstack_ix > cxix) {
1138         cx = &cxstack[cxstack_ix];
1139         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1140                               (long) cxstack_ix, block_type[CxTYPE(cx)]));
1141         /* Note: we don't need to restore the base context info till the end. */
1142         switch (CxTYPE(cx)) {
1143         case CXt_SUBST:
1144             POPSUBST(cx);
1145             continue;  /* not break */
1146         case CXt_SUB:
1147             POPSUB(cx);
1148             break;
1149         case CXt_EVAL:
1150             POPEVAL(cx);
1151             break;
1152         case CXt_LOOP:
1153             POPLOOP(cx);
1154             break;
1155         case CXt_NULL:
1156             break;
1157         }
1158         cxstack_ix--;
1159     }
1160 }
1161
1162 OP *
1163 die_where(char *message)
1164 {
1165     dSP;
1166     if (PL_in_eval) {
1167         I32 cxix;
1168         register PERL_CONTEXT *cx;
1169         I32 gimme;
1170         SV **newsp;
1171
1172         if (message) {
1173             if (PL_in_eval & 4) {
1174                 SV **svp;
1175                 STRLEN klen = strlen(message);
1176
1177                 svp = hv_fetch(ERRHV, message, klen, TRUE);
1178                 if (svp) {
1179                     if (!SvIOK(*svp)) {
1180                         static char prefix[] = "\t(in cleanup) ";
1181                         SV *err = ERRSV;
1182                         sv_upgrade(*svp, SVt_IV);
1183                         (void)SvIOK_only(*svp);
1184                         if (!SvPOK(err))
1185                             sv_setpv(err,"");
1186                         SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1187                         sv_catpvn(err, prefix, sizeof(prefix)-1);
1188                         sv_catpvn(err, message, klen);
1189                     }
1190                     sv_inc(*svp);
1191                 }
1192             }
1193             else
1194                 sv_setpv(ERRSV, message);
1195         }
1196         else
1197             message = SvPVx(ERRSV, PL_na);
1198
1199         while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1200             dounwind(-1);
1201             POPSTACK;
1202         }
1203
1204         if (cxix >= 0) {
1205             I32 optype;
1206
1207             if (cxix < cxstack_ix)
1208                 dounwind(cxix);
1209
1210             POPBLOCK(cx,PL_curpm);
1211             if (CxTYPE(cx) != CXt_EVAL) {
1212                 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1213                 my_exit(1);
1214             }
1215             POPEVAL(cx);
1216
1217             if (gimme == G_SCALAR)
1218                 *++newsp = &PL_sv_undef;
1219             PL_stack_sp = newsp;
1220
1221             LEAVE;
1222
1223             if (optype == OP_REQUIRE) {
1224                 char* msg = SvPVx(ERRSV, PL_na);
1225                 DIE("%s", *msg ? msg : "Compilation failed in require");
1226             }
1227             return pop_return();
1228         }
1229     }
1230     PerlIO_printf(PerlIO_stderr(), "%s",message);
1231     PerlIO_flush(PerlIO_stderr());
1232     my_failure_exit();
1233     /* NOTREACHED */
1234     return 0;
1235 }
1236
1237 PP(pp_xor)
1238 {
1239     djSP; dPOPTOPssrl;
1240     if (SvTRUE(left) != SvTRUE(right))
1241         RETSETYES;
1242     else
1243         RETSETNO;
1244 }
1245
1246 PP(pp_andassign)
1247 {
1248     djSP;
1249     if (!SvTRUE(TOPs))
1250         RETURN;
1251     else
1252         RETURNOP(cLOGOP->op_other);
1253 }
1254
1255 PP(pp_orassign)
1256 {
1257     djSP;
1258     if (SvTRUE(TOPs))
1259         RETURN;
1260     else
1261         RETURNOP(cLOGOP->op_other);
1262 }
1263
1264 PP(pp_caller)
1265 {
1266     djSP;
1267     register I32 cxix = dopoptosub(cxstack_ix);
1268     register PERL_CONTEXT *cx;
1269     register PERL_CONTEXT *ccstack = cxstack;
1270     PERL_SI *top_si = PL_curstackinfo;
1271     I32 dbcxix;
1272     I32 gimme;
1273     HV *hv;
1274     SV *sv;
1275     I32 count = 0;
1276
1277     if (MAXARG)
1278         count = POPi;
1279     EXTEND(SP, 6);
1280     for (;;) {
1281         /* we may be in a higher stacklevel, so dig down deeper */
1282         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1283             top_si = top_si->si_prev;
1284             ccstack = top_si->si_cxstack;
1285             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1286         }
1287         if (cxix < 0) {
1288             if (GIMME != G_ARRAY)
1289                 RETPUSHUNDEF;
1290             RETURN;
1291         }
1292         if (PL_DBsub && cxix >= 0 &&
1293                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1294             count++;
1295         if (!count--)
1296             break;
1297         cxix = dopoptosub_at(ccstack, cxix - 1);
1298     }
1299
1300     cx = &ccstack[cxix];
1301     if (CxTYPE(cx) == CXt_SUB) {
1302         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1303         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1304            field below is defined for any cx. */
1305         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1306             cx = &ccstack[dbcxix];
1307     }
1308
1309     if (GIMME != G_ARRAY) {
1310         hv = cx->blk_oldcop->cop_stash;
1311         if (!hv)
1312             PUSHs(&PL_sv_undef);
1313         else {
1314             dTARGET;
1315             sv_setpv(TARG, HvNAME(hv));
1316             PUSHs(TARG);
1317         }
1318         RETURN;
1319     }
1320
1321     hv = cx->blk_oldcop->cop_stash;
1322     if (!hv)
1323         PUSHs(&PL_sv_undef);
1324     else
1325         PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1326     PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1327     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1328     if (!MAXARG)
1329         RETURN;
1330     if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1331         sv = NEWSV(49, 0);
1332         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1333         PUSHs(sv_2mortal(sv));
1334         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1335     }
1336     else {
1337         PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1338         PUSHs(sv_2mortal(newSViv(0)));
1339     }
1340     gimme = (I32)cx->blk_gimme;
1341     if (gimme == G_VOID)
1342         PUSHs(&PL_sv_undef);
1343     else
1344         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1345     if (CxTYPE(cx) == CXt_EVAL) {
1346         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1347             PUSHs(cx->blk_eval.cur_text);
1348             PUSHs(&PL_sv_no);
1349         }
1350         else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1351             /* Require, put the name. */
1352             PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1353             PUSHs(&PL_sv_yes);
1354         }
1355     }
1356     else if (CxTYPE(cx) == CXt_SUB &&
1357             cx->blk_sub.hasargs &&
1358             PL_curcop->cop_stash == PL_debstash)
1359     {
1360         AV *ary = cx->blk_sub.argarray;
1361         int off = AvARRAY(ary) - AvALLOC(ary);
1362
1363         if (!PL_dbargs) {
1364             GV* tmpgv;
1365             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1366                                 SVt_PVAV)));
1367             GvMULTI_on(tmpgv);
1368             AvREAL_off(PL_dbargs);              /* XXX Should be REIFY */
1369         }
1370
1371         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1372             av_extend(PL_dbargs, AvFILLp(ary) + off);
1373         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1374         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1375     }
1376     RETURN;
1377 }
1378
1379 STATIC I32
1380 sortcv(SV *a, SV *b)
1381 {
1382     dTHR;
1383     I32 oldsaveix = PL_savestack_ix;
1384     I32 oldscopeix = PL_scopestack_ix;
1385     I32 result;
1386     GvSV(PL_firstgv) = a;
1387     GvSV(PL_secondgv) = b;
1388     PL_stack_sp = PL_stack_base;
1389     PL_op = PL_sortcop;
1390     CALLRUNOPS();
1391     if (PL_stack_sp != PL_stack_base + 1)
1392         croak("Sort subroutine didn't return single value");
1393     if (!SvNIOKp(*PL_stack_sp))
1394         croak("Sort subroutine didn't return a numeric value");
1395     result = SvIV(*PL_stack_sp);
1396     while (PL_scopestack_ix > oldscopeix) {
1397         LEAVE;
1398     }
1399     leave_scope(oldsaveix);
1400     return result;
1401 }
1402
1403 PP(pp_reset)
1404 {
1405     djSP;
1406     char *tmps;
1407
1408     if (MAXARG < 1)
1409         tmps = "";
1410     else
1411         tmps = POPp;
1412     sv_reset(tmps, PL_curcop->cop_stash);
1413     PUSHs(&PL_sv_yes);
1414     RETURN;
1415 }
1416
1417 PP(pp_lineseq)
1418 {
1419     return NORMAL;
1420 }
1421
1422 PP(pp_dbstate)
1423 {
1424     PL_curcop = (COP*)PL_op;
1425     TAINT_NOT;          /* Each statement is presumed innocent */
1426     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1427     FREETMPS;
1428
1429     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1430     {
1431         djSP;
1432         register CV *cv;
1433         register PERL_CONTEXT *cx;
1434         I32 gimme = G_ARRAY;
1435         I32 hasargs;
1436         GV *gv;
1437
1438         gv = PL_DBgv;
1439         cv = GvCV(gv);
1440         if (!cv)
1441             DIE("No DB::DB routine defined");
1442
1443         if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1444             return NORMAL;
1445
1446         ENTER;
1447         SAVETMPS;
1448
1449         SAVEI32(PL_debug);
1450         SAVESTACK_POS();
1451         PL_debug = 0;
1452         hasargs = 0;
1453         SPAGAIN;
1454
1455         push_return(PL_op->op_next);
1456         PUSHBLOCK(cx, CXt_SUB, SP);
1457         PUSHSUB(cx);
1458         CvDEPTH(cv)++;
1459         (void)SvREFCNT_inc(cv);
1460         SAVESPTR(PL_curpad);
1461         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1462         RETURNOP(CvSTART(cv));
1463     }
1464     else
1465         return NORMAL;
1466 }
1467
1468 PP(pp_scope)
1469 {
1470     return NORMAL;
1471 }
1472
1473 PP(pp_enteriter)
1474 {
1475     djSP; dMARK;
1476     register PERL_CONTEXT *cx;
1477     I32 gimme = GIMME_V;
1478     SV **svp;
1479
1480     ENTER;
1481     SAVETMPS;
1482
1483 #ifdef USE_THREADS
1484     if (PL_op->op_flags & OPf_SPECIAL)
1485         svp = save_threadsv(PL_op->op_targ);    /* per-thread variable */
1486     else
1487 #endif /* USE_THREADS */
1488     if (PL_op->op_targ) {
1489         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1490         SAVESPTR(*svp);
1491     }
1492     else {
1493         GV *gv = (GV*)POPs;
1494         (void)save_scalar(gv);
1495         svp = &GvSV(gv);                        /* symbol table variable */
1496     }
1497
1498     ENTER;
1499
1500     PUSHBLOCK(cx, CXt_LOOP, SP);
1501     PUSHLOOP(cx, svp, MARK);
1502     if (PL_op->op_flags & OPf_STACKED) {
1503         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1504         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1505             dPOPss;
1506             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1507                 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1508                  if (SvNV(sv) < IV_MIN ||
1509                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1510                      croak("Range iterator outside integer range");
1511                  cx->blk_loop.iterix = SvIV(sv);
1512                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1513             }
1514             else
1515                 cx->blk_loop.iterlval = newSVsv(sv);
1516         }
1517     }
1518     else {
1519         cx->blk_loop.iterary = PL_curstack;
1520         AvFILLp(PL_curstack) = SP - PL_stack_base;
1521         cx->blk_loop.iterix = MARK - PL_stack_base;
1522     }
1523
1524     RETURN;
1525 }
1526
1527 PP(pp_enterloop)
1528 {
1529     djSP;
1530     register PERL_CONTEXT *cx;
1531     I32 gimme = GIMME_V;
1532
1533     ENTER;
1534     SAVETMPS;
1535     ENTER;
1536
1537     PUSHBLOCK(cx, CXt_LOOP, SP);
1538     PUSHLOOP(cx, 0, SP);
1539
1540     RETURN;
1541 }
1542
1543 PP(pp_leaveloop)
1544 {
1545     djSP;
1546     register PERL_CONTEXT *cx;
1547     struct block_loop cxloop;
1548     I32 gimme;
1549     SV **newsp;
1550     PMOP *newpm;
1551     SV **mark;
1552
1553     POPBLOCK(cx,newpm);
1554     mark = newsp;
1555     POPLOOP1(cx);       /* Delay POPLOOP2 until stack values are safe */
1556
1557     TAINT_NOT;
1558     if (gimme == G_VOID)
1559         ; /* do nothing */
1560     else if (gimme == G_SCALAR) {
1561         if (mark < SP)
1562             *++newsp = sv_mortalcopy(*SP);
1563         else
1564             *++newsp = &PL_sv_undef;
1565     }
1566     else {
1567         while (mark < SP) {
1568             *++newsp = sv_mortalcopy(*++mark);
1569             TAINT_NOT;          /* Each item is independent */
1570         }
1571     }
1572     SP = newsp;
1573     PUTBACK;
1574
1575     POPLOOP2();         /* Stack values are safe: release loop vars ... */
1576     PL_curpm = newpm;   /* ... and pop $1 et al */
1577
1578     LEAVE;
1579     LEAVE;
1580
1581     return NORMAL;
1582 }
1583
1584 PP(pp_return)
1585 {
1586     djSP; dMARK;
1587     I32 cxix;
1588     register PERL_CONTEXT *cx;
1589     struct block_sub cxsub;
1590     bool popsub2 = FALSE;
1591     I32 gimme;
1592     SV **newsp;
1593     PMOP *newpm;
1594     I32 optype = 0;
1595
1596     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1597         if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1598             if (cxstack_ix > PL_sortcxix)
1599                 dounwind(PL_sortcxix);
1600             AvARRAY(PL_curstack)[1] = *SP;
1601             PL_stack_sp = PL_stack_base + 1;
1602             return 0;
1603         }
1604     }
1605
1606     cxix = dopoptosub(cxstack_ix);
1607     if (cxix < 0)
1608         DIE("Can't return outside a subroutine");
1609     if (cxix < cxstack_ix)
1610         dounwind(cxix);
1611
1612     POPBLOCK(cx,newpm);
1613     switch (CxTYPE(cx)) {
1614     case CXt_SUB:
1615         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1616         popsub2 = TRUE;
1617         break;
1618     case CXt_EVAL:
1619         POPEVAL(cx);
1620         if (optype == OP_REQUIRE &&
1621             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1622         {
1623             /* Unassume the success we assumed earlier. */
1624             char *name = cx->blk_eval.old_name;
1625             (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1626             DIE("%s did not return a true value", name);
1627         }
1628         break;
1629     default:
1630         DIE("panic: return");
1631     }
1632
1633     TAINT_NOT;
1634     if (gimme == G_SCALAR) {
1635         if (MARK < SP) {
1636             if (popsub2) {
1637                 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1638                     if (SvTEMP(TOPs)) {
1639                         *++newsp = SvREFCNT_inc(*SP);
1640                         FREETMPS;
1641                         sv_2mortal(*newsp);
1642                     } else {
1643                         FREETMPS;
1644                         *++newsp = sv_mortalcopy(*SP);
1645                     }
1646                 } else
1647                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1648             } else
1649                 *++newsp = sv_mortalcopy(*SP);
1650         } else
1651             *++newsp = &PL_sv_undef;
1652     }
1653     else if (gimme == G_ARRAY) {
1654         while (++MARK <= SP) {
1655             *++newsp = (popsub2 && SvTEMP(*MARK))
1656                         ? *MARK : sv_mortalcopy(*MARK);
1657             TAINT_NOT;          /* Each item is independent */
1658         }
1659     }
1660     PL_stack_sp = newsp;
1661
1662     /* Stack values are safe: */
1663     if (popsub2) {
1664         POPSUB2();      /* release CV and @_ ... */
1665     }
1666     PL_curpm = newpm;   /* ... and pop $1 et al */
1667
1668     LEAVE;
1669     return pop_return();
1670 }
1671
1672 PP(pp_last)
1673 {
1674     djSP;
1675     I32 cxix;
1676     register PERL_CONTEXT *cx;
1677     struct block_loop cxloop;
1678     struct block_sub cxsub;
1679     I32 pop2 = 0;
1680     I32 gimme;
1681     I32 optype;
1682     OP *nextop;
1683     SV **newsp;
1684     PMOP *newpm;
1685     SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1686
1687     if (PL_op->op_flags & OPf_SPECIAL) {
1688         cxix = dopoptoloop(cxstack_ix);
1689         if (cxix < 0)
1690             DIE("Can't \"last\" outside a block");
1691     }
1692     else {
1693         cxix = dopoptolabel(cPVOP->op_pv);
1694         if (cxix < 0)
1695             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1696     }
1697     if (cxix < cxstack_ix)
1698         dounwind(cxix);
1699
1700     POPBLOCK(cx,newpm);
1701     switch (CxTYPE(cx)) {
1702     case CXt_LOOP:
1703         POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
1704         pop2 = CXt_LOOP;
1705         nextop = cxloop.last_op->op_next;
1706         break;
1707     case CXt_SUB:
1708         POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
1709         pop2 = CXt_SUB;
1710         nextop = pop_return();
1711         break;
1712     case CXt_EVAL:
1713         POPEVAL(cx);
1714         nextop = pop_return();
1715         break;
1716     default:
1717         DIE("panic: last");
1718     }
1719
1720     TAINT_NOT;
1721     if (gimme == G_SCALAR) {
1722         if (MARK < SP)
1723             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1724                         ? *SP : sv_mortalcopy(*SP);
1725         else
1726             *++newsp = &PL_sv_undef;
1727     }
1728     else if (gimme == G_ARRAY) {
1729         while (++MARK <= SP) {
1730             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1731                         ? *MARK : sv_mortalcopy(*MARK);
1732             TAINT_NOT;          /* Each item is independent */
1733         }
1734     }
1735     SP = newsp;
1736     PUTBACK;
1737
1738     /* Stack values are safe: */
1739     switch (pop2) {
1740     case CXt_LOOP:
1741         POPLOOP2();     /* release loop vars ... */
1742         LEAVE;
1743         break;
1744     case CXt_SUB:
1745         POPSUB2();      /* release CV and @_ ... */
1746         break;
1747     }
1748     PL_curpm = newpm;   /* ... and pop $1 et al */
1749
1750     LEAVE;
1751     return nextop;
1752 }
1753
1754 PP(pp_next)
1755 {
1756     I32 cxix;
1757     register PERL_CONTEXT *cx;
1758     I32 oldsave;
1759
1760     if (PL_op->op_flags & OPf_SPECIAL) {
1761         cxix = dopoptoloop(cxstack_ix);
1762         if (cxix < 0)
1763             DIE("Can't \"next\" outside a block");
1764     }
1765     else {
1766         cxix = dopoptolabel(cPVOP->op_pv);
1767         if (cxix < 0)
1768             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1769     }
1770     if (cxix < cxstack_ix)
1771         dounwind(cxix);
1772
1773     TOPBLOCK(cx);
1774     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1775     LEAVE_SCOPE(oldsave);
1776     return cx->blk_loop.next_op;
1777 }
1778
1779 PP(pp_redo)
1780 {
1781     I32 cxix;
1782     register PERL_CONTEXT *cx;
1783     I32 oldsave;
1784
1785     if (PL_op->op_flags & OPf_SPECIAL) {
1786         cxix = dopoptoloop(cxstack_ix);
1787         if (cxix < 0)
1788             DIE("Can't \"redo\" outside a block");
1789     }
1790     else {
1791         cxix = dopoptolabel(cPVOP->op_pv);
1792         if (cxix < 0)
1793             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1794     }
1795     if (cxix < cxstack_ix)
1796         dounwind(cxix);
1797
1798     TOPBLOCK(cx);
1799     oldsave = PL_scopestack[PL_scopestack_ix - 1];
1800     LEAVE_SCOPE(oldsave);
1801     return cx->blk_loop.redo_op;
1802 }
1803
1804 STATIC OP *
1805 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1806 {
1807     OP *kid;
1808     OP **ops = opstack;
1809     static char too_deep[] = "Target of goto is too deeply nested";
1810
1811     if (ops >= oplimit)
1812         croak(too_deep);
1813     if (o->op_type == OP_LEAVE ||
1814         o->op_type == OP_SCOPE ||
1815         o->op_type == OP_LEAVELOOP ||
1816         o->op_type == OP_LEAVETRY)
1817     {
1818         *ops++ = cUNOPo->op_first;
1819         if (ops >= oplimit)
1820             croak(too_deep);
1821     }
1822     *ops = 0;
1823     if (o->op_flags & OPf_KIDS) {
1824         dTHR;
1825         /* First try all the kids at this level, since that's likeliest. */
1826         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1827             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1828                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1829                 return kid;
1830         }
1831         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1832             if (kid == PL_lastgotoprobe)
1833                 continue;
1834             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1835                 (ops == opstack ||
1836                  (ops[-1]->op_type != OP_NEXTSTATE &&
1837                   ops[-1]->op_type != OP_DBSTATE)))
1838                 *ops++ = kid;
1839             if (o = dofindlabel(kid, label, ops, oplimit))
1840                 return o;
1841         }
1842     }
1843     *ops = 0;
1844     return 0;
1845 }
1846
1847 PP(pp_dump)
1848 {
1849     return pp_goto(ARGS);
1850     /*NOTREACHED*/
1851 }
1852
1853 PP(pp_goto)
1854 {
1855     djSP;
1856     OP *retop = 0;
1857     I32 ix;
1858     register PERL_CONTEXT *cx;
1859 #define GOTO_DEPTH 64
1860     OP *enterops[GOTO_DEPTH];
1861     char *label;
1862     int do_dump = (PL_op->op_type == OP_DUMP);
1863
1864     label = 0;
1865     if (PL_op->op_flags & OPf_STACKED) {
1866         SV *sv = POPs;
1867
1868         /* This egregious kludge implements goto &subroutine */
1869         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1870             I32 cxix;
1871             register PERL_CONTEXT *cx;
1872             CV* cv = (CV*)SvRV(sv);
1873             SV** mark;
1874             I32 items = 0;
1875             I32 oldsave;
1876             int arg_was_real = 0;
1877
1878         retry:
1879             if (!CvROOT(cv) && !CvXSUB(cv)) {
1880                 GV *gv = CvGV(cv);
1881                 GV *autogv;
1882                 if (gv) {
1883                     SV *tmpstr;
1884                     /* autoloaded stub? */
1885                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
1886                         goto retry;
1887                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1888                                           GvNAMELEN(gv), FALSE);
1889                     if (autogv && (cv = GvCV(autogv)))
1890                         goto retry;
1891                     tmpstr = sv_newmortal();
1892                     gv_efullname3(tmpstr, gv, Nullch);
1893                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1894                 }
1895                 DIE("Goto undefined subroutine");
1896             }
1897
1898             /* First do some returnish stuff. */
1899             cxix = dopoptosub(cxstack_ix);
1900             if (cxix < 0)
1901                 DIE("Can't goto subroutine outside a subroutine");
1902             if (cxix < cxstack_ix)
1903                 dounwind(cxix);
1904             TOPBLOCK(cx);
1905             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1906                 DIE("Can't goto subroutine from an eval-string");
1907             mark = PL_stack_sp;
1908             if (CxTYPE(cx) == CXt_SUB &&
1909                 cx->blk_sub.hasargs) {   /* put @_ back onto stack */
1910                 AV* av = cx->blk_sub.argarray;
1911
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 #ifndef USE_THREADS
1918                 SvREFCNT_dec(GvAV(PL_defgv));
1919                 GvAV(PL_defgv) = cx->blk_sub.savearray;
1920 #endif /* USE_THREADS */
1921                 if (AvREAL(av)) {
1922                     arg_was_real = 1;
1923                     AvREAL_off(av);     /* so av_clear() won't clobber elts */
1924                 }
1925                 av_clear(av);
1926             }
1927             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
1928                 AV* av;
1929                 int i;
1930 #ifdef USE_THREADS
1931                 av = (AV*)PL_curpad[0];
1932 #else
1933                 av = GvAV(PL_defgv);
1934 #endif
1935                 items = AvFILLp(av) + 1;
1936                 PL_stack_sp++;
1937                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1938                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1939                 PL_stack_sp += items;
1940             }
1941             if (CxTYPE(cx) == CXt_SUB &&
1942                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1943                 SvREFCNT_dec(cx->blk_sub.cv);
1944             oldsave = PL_scopestack[PL_scopestack_ix - 1];
1945             LEAVE_SCOPE(oldsave);
1946
1947             /* Now do some callish stuff. */
1948             SAVETMPS;
1949             if (CvXSUB(cv)) {
1950                 if (CvOLDSTYLE(cv)) {
1951                     I32 (*fp3)_((int,int,int));
1952                     while (SP > mark) {
1953                         SP[1] = SP[0];
1954                         SP--;
1955                     }
1956                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1957                     items = (*fp3)(CvXSUBANY(cv).any_i32,
1958                                    mark - PL_stack_base + 1,
1959                                    items);
1960                     SP = PL_stack_base + items;
1961                 }
1962                 else {
1963                     SV **newsp;
1964                     I32 gimme;
1965
1966                     PL_stack_sp--;              /* There is no cv arg. */
1967                     /* Push a mark for the start of arglist */
1968                     PUSHMARK(mark);
1969                     (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1970                     /* Pop the current context like a decent sub should */
1971                     POPBLOCK(cx, PL_curpm);
1972                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1973                 }
1974                 LEAVE;
1975                 return pop_return();
1976             }
1977             else {
1978                 AV* padlist = CvPADLIST(cv);
1979                 SV** svp = AvARRAY(padlist);
1980                 if (CxTYPE(cx) == CXt_EVAL) {
1981                     PL_in_eval = cx->blk_eval.old_in_eval;
1982                     PL_eval_root = cx->blk_eval.old_eval_root;
1983                     cx->cx_type = CXt_SUB;
1984                     cx->blk_sub.hasargs = 0;
1985                 }
1986                 cx->blk_sub.cv = cv;
1987                 cx->blk_sub.olddepth = CvDEPTH(cv);
1988                 CvDEPTH(cv)++;
1989                 if (CvDEPTH(cv) < 2)
1990                     (void)SvREFCNT_inc(cv);
1991                 else {  /* save temporaries on recursion? */
1992                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
1993                         sub_crush_depth(cv);
1994                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
1995                         AV *newpad = newAV();
1996                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1997                         I32 ix = AvFILLp((AV*)svp[1]);
1998                         svp = AvARRAY(svp[0]);
1999                         for ( ;ix > 0; ix--) {
2000                             if (svp[ix] != &PL_sv_undef) {
2001                                 char *name = SvPVX(svp[ix]);
2002                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2003                                     || *name == '&')
2004                                 {
2005                                     /* outer lexical or anon code */
2006                                     av_store(newpad, ix,
2007                                         SvREFCNT_inc(oldpad[ix]) );
2008                                 }
2009                                 else {          /* our own lexical */
2010                                     if (*name == '@')
2011                                         av_store(newpad, ix, sv = (SV*)newAV());
2012                                     else if (*name == '%')
2013                                         av_store(newpad, ix, sv = (SV*)newHV());
2014                                     else
2015                                         av_store(newpad, ix, sv = NEWSV(0,0));
2016                                     SvPADMY_on(sv);
2017                                 }
2018                             }
2019                             else {
2020                                 av_store(newpad, ix, sv = NEWSV(0,0));
2021                                 SvPADTMP_on(sv);
2022                             }
2023                         }
2024                         if (cx->blk_sub.hasargs) {
2025                             AV* av = newAV();
2026                             av_extend(av, 0);
2027                             av_store(newpad, 0, (SV*)av);
2028                             AvFLAGS(av) = AVf_REIFY;
2029                         }
2030                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2031                         AvFILLp(padlist) = CvDEPTH(cv);
2032                         svp = AvARRAY(padlist);
2033                     }
2034                 }
2035 #ifdef USE_THREADS
2036                 if (!cx->blk_sub.hasargs) {
2037                     AV* av = (AV*)PL_curpad[0];
2038
2039                     items = AvFILLp(av) + 1;
2040                     if (items) {
2041                         /* Mark is at the end of the stack. */
2042                         EXTEND(SP, items);
2043                         Copy(AvARRAY(av), SP + 1, items, SV*);
2044                         SP += items;
2045                         PUTBACK ;
2046                     }
2047                 }
2048 #endif /* USE_THREADS */
2049                 SAVESPTR(PL_curpad);
2050                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2051 #ifndef USE_THREADS
2052                 if (cx->blk_sub.hasargs)
2053 #endif /* USE_THREADS */
2054                 {
2055                     AV* av = (AV*)PL_curpad[0];
2056                     SV** ary;
2057
2058 #ifndef USE_THREADS
2059                     cx->blk_sub.savearray = GvAV(PL_defgv);
2060                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2061 #endif /* USE_THREADS */
2062                     cx->blk_sub.argarray = av;
2063                     ++mark;
2064
2065                     if (items >= AvMAX(av) + 1) {
2066                         ary = AvALLOC(av);
2067                         if (AvARRAY(av) != ary) {
2068                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2069                             SvPVX(av) = (char*)ary;
2070                         }
2071                         if (items >= AvMAX(av) + 1) {
2072                             AvMAX(av) = items - 1;
2073                             Renew(ary,items+1,SV*);
2074                             AvALLOC(av) = ary;
2075                             SvPVX(av) = (char*)ary;
2076                         }
2077                     }
2078                     Copy(mark,AvARRAY(av),items,SV*);
2079                     AvFILLp(av) = items - 1;
2080                     /* preserve @_ nature */
2081                     if (arg_was_real) {
2082                         AvREIFY_off(av);
2083                         AvREAL_on(av);
2084                     }
2085                     while (items--) {
2086                         if (*mark)
2087                             SvTEMP_off(*mark);
2088                         mark++;
2089                     }
2090                 }
2091                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2092                     /*
2093                      * We do not care about using sv to call CV;
2094                      * it's for informational purposes only.
2095                      */
2096                     SV *sv = GvSV(PL_DBsub);
2097                     CV *gotocv;
2098
2099                     if (PERLDB_SUB_NN) {
2100                         SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2101                     } else {
2102                         save_item(sv);
2103                         gv_efullname3(sv, CvGV(cv), Nullch);
2104                     }
2105                     if (  PERLDB_GOTO
2106                           && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2107                         PUSHMARK( PL_stack_sp );
2108                         perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2109                         PL_stack_sp--;
2110                     }
2111                 }
2112                 RETURNOP(CvSTART(cv));
2113             }
2114         }
2115         else
2116             label = SvPV(sv,PL_na);
2117     }
2118     else if (PL_op->op_flags & OPf_SPECIAL) {
2119         if (! do_dump)
2120             DIE("goto must have label");
2121     }
2122     else
2123         label = cPVOP->op_pv;
2124
2125     if (label && *label) {
2126         OP *gotoprobe = 0;
2127
2128         /* find label */
2129
2130         PL_lastgotoprobe = 0;
2131         *enterops = 0;
2132         for (ix = cxstack_ix; ix >= 0; ix--) {
2133             cx = &cxstack[ix];
2134             switch (CxTYPE(cx)) {
2135             case CXt_EVAL:
2136                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2137                 break;
2138             case CXt_LOOP:
2139                 gotoprobe = cx->blk_oldcop->op_sibling;
2140                 break;
2141             case CXt_SUBST:
2142                 continue;
2143             case CXt_BLOCK:
2144                 if (ix)
2145                     gotoprobe = cx->blk_oldcop->op_sibling;
2146                 else
2147                     gotoprobe = PL_main_root;
2148                 break;
2149             case CXt_SUB:
2150                 if (CvDEPTH(cx->blk_sub.cv)) {
2151                     gotoprobe = CvROOT(cx->blk_sub.cv);
2152                     break;
2153                 }
2154                 /* FALL THROUGH */
2155             case CXt_NULL:
2156                 DIE("Can't \"goto\" outside a block");
2157             default:
2158                 if (ix)
2159                     DIE("panic: goto");
2160                 gotoprobe = PL_main_root;
2161                 break;
2162             }
2163             retop = dofindlabel(gotoprobe, label,
2164                                 enterops, enterops + GOTO_DEPTH);
2165             if (retop)
2166                 break;
2167             PL_lastgotoprobe = gotoprobe;
2168         }
2169         if (!retop)
2170             DIE("Can't find label %s", label);
2171
2172         /* pop unwanted frames */
2173
2174         if (ix < cxstack_ix) {
2175             I32 oldsave;
2176
2177             if (ix < 0)
2178                 ix = 0;
2179             dounwind(ix);
2180             TOPBLOCK(cx);
2181             oldsave = PL_scopestack[PL_scopestack_ix];
2182             LEAVE_SCOPE(oldsave);
2183         }
2184
2185         /* push wanted frames */
2186
2187         if (*enterops && enterops[1]) {
2188             OP *oldop = PL_op;
2189             for (ix = 1; enterops[ix]; ix++) {
2190                 PL_op = enterops[ix];
2191                 /* Eventually we may want to stack the needed arguments
2192                  * for each op.  For now, we punt on the hard ones. */
2193                 if (PL_op->op_type == OP_ENTERITER)
2194                     DIE("Can't \"goto\" into the middle of a foreach loop",
2195                         label);
2196                 (CALLOP->op_ppaddr)(ARGS);
2197             }
2198             PL_op = oldop;
2199         }
2200     }
2201
2202     if (do_dump) {
2203 #ifdef VMS
2204         if (!retop) retop = PL_main_start;
2205 #endif
2206         PL_restartop = retop;
2207         PL_do_undump = TRUE;
2208
2209         my_unexec();
2210
2211         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2212         PL_do_undump = FALSE;
2213     }
2214
2215     RETURNOP(retop);
2216 }
2217
2218 PP(pp_exit)
2219 {
2220     djSP;
2221     I32 anum;
2222
2223     if (MAXARG < 1)
2224         anum = 0;
2225     else {
2226         anum = SvIVx(POPs);
2227 #ifdef VMSISH_EXIT
2228         if (anum == 1 && VMSISH_EXIT)
2229             anum = 0;
2230 #endif
2231     }
2232     my_exit(anum);
2233     PUSHs(&PL_sv_undef);
2234     RETURN;
2235 }
2236
2237 #ifdef NOTYET
2238 PP(pp_nswitch)
2239 {
2240     djSP;
2241     double value = SvNVx(GvSV(cCOP->cop_gv));
2242     register I32 match = I_32(value);
2243
2244     if (value < 0.0) {
2245         if (((double)match) > value)
2246             --match;            /* was fractional--truncate other way */
2247     }
2248     match -= cCOP->uop.scop.scop_offset;
2249     if (match < 0)
2250         match = 0;
2251     else if (match > cCOP->uop.scop.scop_max)
2252         match = cCOP->uop.scop.scop_max;
2253     PL_op = cCOP->uop.scop.scop_next[match];
2254     RETURNOP(PL_op);
2255 }
2256
2257 PP(pp_cswitch)
2258 {
2259     djSP;
2260     register I32 match;
2261
2262     if (PL_multiline)
2263         PL_op = PL_op->op_next;                 /* can't assume anything */
2264     else {
2265         match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
2266         match -= cCOP->uop.scop.scop_offset;
2267         if (match < 0)
2268             match = 0;
2269         else if (match > cCOP->uop.scop.scop_max)
2270             match = cCOP->uop.scop.scop_max;
2271         PL_op = cCOP->uop.scop.scop_next[match];
2272     }
2273     RETURNOP(PL_op);
2274 }
2275 #endif
2276
2277 /* Eval. */
2278
2279 STATIC void
2280 save_lines(AV *array, SV *sv)
2281 {
2282     register char *s = SvPVX(sv);
2283     register char *send = SvPVX(sv) + SvCUR(sv);
2284     register char *t;
2285     register I32 line = 1;
2286
2287     while (s && s < send) {
2288         SV *tmpstr = NEWSV(85,0);
2289
2290         sv_upgrade(tmpstr, SVt_PVMG);
2291         t = strchr(s, '\n');
2292         if (t)
2293             t++;
2294         else
2295             t = send;
2296
2297         sv_setpvn(tmpstr, s, t - s);
2298         av_store(array, line++, tmpstr);
2299         s = t;
2300     }
2301 }
2302
2303 STATIC OP *
2304 docatch(OP *o)
2305 {
2306     dTHR;
2307     int ret;
2308     OP *oldop = PL_op;
2309     dJMPENV;
2310
2311     PL_op = o;
2312 #ifdef DEBUGGING
2313     assert(CATCH_GET == TRUE);
2314     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
2315 #endif
2316     JMPENV_PUSH(ret);
2317     switch (ret) {
2318     default:                            /* topmost level handles it */
2319 pass_the_buck:
2320         JMPENV_POP;
2321         PL_op = oldop;
2322         JMPENV_JUMP(ret);
2323         /* NOTREACHED */
2324     case 3:
2325         if (!PL_restartop)
2326             goto pass_the_buck;
2327         PL_op = PL_restartop;
2328         PL_restartop = 0;
2329         /* FALL THROUGH */
2330     case 0:
2331         CALLRUNOPS();
2332         break;
2333     }
2334     JMPENV_POP;
2335     PL_op = oldop;
2336     return Nullop;
2337 }
2338
2339 OP *
2340 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2341 /* sv Text to convert to OP tree. */
2342 /* startop op_free() this to undo. */
2343 /* code Short string id of the caller. */
2344 {
2345     dSP;                                /* Make POPBLOCK work. */
2346     PERL_CONTEXT *cx;
2347     SV **newsp;
2348     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2349     I32 optype;
2350     OP dummy;
2351     OP *oop = PL_op, *rop;
2352     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2353     char *safestr;
2354
2355     ENTER;
2356     lex_start(sv);
2357     SAVETMPS;
2358     /* switch to eval mode */
2359
2360     if (PL_curcop == &PL_compiling) {
2361         SAVESPTR(PL_compiling.cop_stash);
2362         PL_compiling.cop_stash = PL_curstash;
2363     }
2364     SAVESPTR(PL_compiling.cop_filegv);
2365     SAVEI16(PL_compiling.cop_line);
2366     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2367     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2368     PL_compiling.cop_line = 1;
2369     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2370        deleting the eval's FILEGV from the stash before gv_check() runs
2371        (i.e. before run-time proper). To work around the coredump that
2372        ensues, we always turn GvMULTI_on for any globals that were
2373        introduced within evals. See force_ident(). GSAR 96-10-12 */
2374     safestr = savepv(tmpbuf);
2375     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2376     SAVEHINTS();
2377 #ifdef OP_IN_REGISTER
2378     PL_opsave = op;
2379 #else
2380     SAVEPPTR(PL_op);
2381 #endif
2382     PL_hints = 0;
2383
2384     PL_op = &dummy;
2385     PL_op->op_type = OP_ENTEREVAL;
2386     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2387     PUSHBLOCK(cx, CXt_EVAL, SP);
2388     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2389     rop = doeval(G_SCALAR, startop);
2390     POPBLOCK(cx,PL_curpm);
2391     POPEVAL(cx);
2392
2393     (*startop)->op_type = OP_NULL;
2394     (*startop)->op_ppaddr = ppaddr[OP_NULL];
2395     lex_end();
2396     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2397     LEAVE;
2398     if (PL_curcop == &PL_compiling)
2399         PL_compiling.op_private = PL_hints;
2400 #ifdef OP_IN_REGISTER
2401     op = PL_opsave;
2402 #endif
2403     return rop;
2404 }
2405
2406 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2407 STATIC OP *
2408 doeval(int gimme, OP** startop)
2409 {
2410     dSP;
2411     OP *saveop = PL_op;
2412     HV *newstash;
2413     CV *caller;
2414     AV* comppadlist;
2415     I32 i;
2416
2417     PL_in_eval = 1;
2418
2419     PUSHMARK(SP);
2420
2421     /* set up a scratch pad */
2422
2423     SAVEI32(PL_padix);
2424     SAVESPTR(PL_curpad);
2425     SAVESPTR(PL_comppad);
2426     SAVESPTR(PL_comppad_name);
2427     SAVEI32(PL_comppad_name_fill);
2428     SAVEI32(PL_min_intro_pending);
2429     SAVEI32(PL_max_intro_pending);
2430
2431     caller = PL_compcv;
2432     for (i = cxstack_ix - 1; i >= 0; i--) {
2433         PERL_CONTEXT *cx = &cxstack[i];
2434         if (CxTYPE(cx) == CXt_EVAL)
2435             break;
2436         else if (CxTYPE(cx) == CXt_SUB) {
2437             caller = cx->blk_sub.cv;
2438             break;
2439         }
2440     }
2441
2442     SAVESPTR(PL_compcv);
2443     PL_compcv = (CV*)NEWSV(1104,0);
2444     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2445     CvUNIQUE_on(PL_compcv);
2446 #ifdef USE_THREADS
2447     CvOWNER(PL_compcv) = 0;
2448     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2449     MUTEX_INIT(CvMUTEXP(PL_compcv));
2450 #endif /* USE_THREADS */
2451
2452     PL_comppad = newAV();
2453     av_push(PL_comppad, Nullsv);
2454     PL_curpad = AvARRAY(PL_comppad);
2455     PL_comppad_name = newAV();
2456     PL_comppad_name_fill = 0;
2457     PL_min_intro_pending = 0;
2458     PL_padix = 0;
2459 #ifdef USE_THREADS
2460     av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2461     PL_curpad[0] = (SV*)newAV();
2462     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2463 #endif /* USE_THREADS */
2464
2465     comppadlist = newAV();
2466     AvREAL_off(comppadlist);
2467     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2468     av_store(comppadlist, 1, (SV*)PL_comppad);
2469     CvPADLIST(PL_compcv) = comppadlist;
2470
2471     if (!saveop || saveop->op_type != OP_REQUIRE)
2472         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2473
2474     SAVEFREESV(PL_compcv);
2475
2476     /* make sure we compile in the right package */
2477
2478     newstash = PL_curcop->cop_stash;
2479     if (PL_curstash != newstash) {
2480         SAVESPTR(PL_curstash);
2481         PL_curstash = newstash;
2482     }
2483     SAVESPTR(PL_beginav);
2484     PL_beginav = newAV();
2485     SAVEFREESV(PL_beginav);
2486
2487     /* try to compile it */
2488
2489     PL_eval_root = Nullop;
2490     PL_error_count = 0;
2491     PL_curcop = &PL_compiling;
2492     PL_curcop->cop_arybase = 0;
2493     SvREFCNT_dec(PL_rs);
2494     PL_rs = newSVpv("\n", 1);
2495     if (saveop && saveop->op_flags & OPf_SPECIAL)
2496         PL_in_eval |= 4;
2497     else
2498         sv_setpv(ERRSV,"");
2499     if (yyparse() || PL_error_count || !PL_eval_root) {
2500         SV **newsp;
2501         I32 gimme;
2502         PERL_CONTEXT *cx;
2503         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2504
2505         PL_op = saveop;
2506         if (PL_eval_root) {
2507             op_free(PL_eval_root);
2508             PL_eval_root = Nullop;
2509         }
2510         SP = PL_stack_base + POPMARK;           /* pop original mark */
2511         if (!startop) {
2512             POPBLOCK(cx,PL_curpm);
2513             POPEVAL(cx);
2514             pop_return();
2515         }
2516         lex_end();
2517         LEAVE;
2518         if (optype == OP_REQUIRE) {
2519             char* msg = SvPVx(ERRSV, PL_na);
2520             DIE("%s", *msg ? msg : "Compilation failed in require");
2521         } else if (startop) {
2522             char* msg = SvPVx(ERRSV, PL_na);
2523
2524             POPBLOCK(cx,PL_curpm);
2525             POPEVAL(cx);
2526             croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2527         }
2528         SvREFCNT_dec(PL_rs);
2529         PL_rs = SvREFCNT_inc(PL_nrs);
2530 #ifdef USE_THREADS
2531         MUTEX_LOCK(&PL_eval_mutex);
2532         PL_eval_owner = 0;
2533         COND_SIGNAL(&PL_eval_cond);
2534         MUTEX_UNLOCK(&PL_eval_mutex);
2535 #endif /* USE_THREADS */
2536         RETPUSHUNDEF;
2537     }
2538     SvREFCNT_dec(PL_rs);
2539     PL_rs = SvREFCNT_inc(PL_nrs);
2540     PL_compiling.cop_line = 0;
2541     if (startop) {
2542         *startop = PL_eval_root;
2543         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2544         CvOUTSIDE(PL_compcv) = Nullcv;
2545     } else
2546         SAVEFREEOP(PL_eval_root);
2547     if (gimme & G_VOID)
2548         scalarvoid(PL_eval_root);
2549     else if (gimme & G_ARRAY)
2550         list(PL_eval_root);
2551     else
2552         scalar(PL_eval_root);
2553
2554     DEBUG_x(dump_eval());
2555
2556     /* Register with debugger: */
2557     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2558         CV *cv = perl_get_cv("DB::postponed", FALSE);
2559         if (cv) {
2560             dSP;
2561             PUSHMARK(SP);
2562             XPUSHs((SV*)PL_compiling.cop_filegv);
2563             PUTBACK;
2564             perl_call_sv((SV*)cv, G_DISCARD);
2565         }
2566     }
2567
2568     /* compiled okay, so do it */
2569
2570     CvDEPTH(PL_compcv) = 1;
2571     SP = PL_stack_base + POPMARK;               /* pop original mark */
2572     PL_op = saveop;                     /* The caller may need it. */
2573 #ifdef USE_THREADS
2574     MUTEX_LOCK(&PL_eval_mutex);
2575     PL_eval_owner = 0;
2576     COND_SIGNAL(&PL_eval_cond);
2577     MUTEX_UNLOCK(&PL_eval_mutex);
2578 #endif /* USE_THREADS */
2579
2580     RETURNOP(PL_eval_start);
2581 }
2582
2583 PP(pp_require)
2584 {
2585     djSP;
2586     register PERL_CONTEXT *cx;
2587     SV *sv;
2588     char *name;
2589     STRLEN len;
2590     char *tryname;
2591     SV *namesv = Nullsv;
2592     SV** svp;
2593     I32 gimme = G_SCALAR;
2594     PerlIO *tryrsfp = 0;
2595
2596     sv = POPs;
2597     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2598         SET_NUMERIC_STANDARD();
2599         if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2600             DIE("Perl %s required--this is only version %s, stopped",
2601                 SvPV(sv,PL_na),PL_patchlevel);
2602         RETPUSHYES;
2603     }
2604     name = SvPV(sv, len);
2605     if (!(name && len > 0 && *name))
2606         DIE("Null filename used");
2607     TAINT_PROPER("require");
2608     if (PL_op->op_type == OP_REQUIRE &&
2609       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2610       *svp != &PL_sv_undef)
2611         RETPUSHYES;
2612
2613     /* prepare to compile file */
2614
2615     if (*name == '/' ||
2616         (*name == '.' &&
2617             (name[1] == '/' ||
2618              (name[1] == '.' && name[2] == '/')))
2619 #ifdef DOSISH
2620       || (name[0] && name[1] == ':')
2621 #endif
2622 #ifdef WIN32
2623       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2624 #endif
2625 #ifdef VMS
2626         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2627             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2628 #endif
2629     )
2630     {
2631         tryname = name;
2632         tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2633     }
2634     else {
2635         AV *ar = GvAVn(PL_incgv);
2636         I32 i;
2637 #ifdef VMS
2638         char *unixname;
2639         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2640 #endif
2641         {
2642             namesv = NEWSV(806, 0);
2643             for (i = 0; i <= AvFILL(ar); i++) {
2644                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2645 #ifdef VMS
2646                 char *unixdir;
2647                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2648                     continue;
2649                 sv_setpv(namesv, unixdir);
2650                 sv_catpv(namesv, unixname);
2651 #else
2652                 sv_setpvf(namesv, "%s/%s", dir, name);
2653 #endif
2654                 TAINT_PROPER("require");
2655                 tryname = SvPVX(namesv);
2656                 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2657                 if (tryrsfp) {
2658                     if (tryname[0] == '.' && tryname[1] == '/')
2659                         tryname += 2;
2660                     break;
2661                 }
2662             }
2663         }
2664     }
2665     SAVESPTR(PL_compiling.cop_filegv);
2666     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2667     SvREFCNT_dec(namesv);
2668     if (!tryrsfp) {
2669         if (PL_op->op_type == OP_REQUIRE) {
2670             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2671             SV *dirmsgsv = NEWSV(0, 0);
2672             AV *ar = GvAVn(PL_incgv);
2673             I32 i;
2674             if (instr(SvPVX(msg), ".h "))
2675                 sv_catpv(msg, " (change .h to .ph maybe?)");
2676             if (instr(SvPVX(msg), ".ph "))
2677                 sv_catpv(msg, " (did you run h2ph?)");
2678             sv_catpv(msg, " (@INC contains:");
2679             for (i = 0; i <= AvFILL(ar); i++) {
2680                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
2681                 sv_setpvf(dirmsgsv, " %s", dir);
2682                 sv_catsv(msg, dirmsgsv);
2683             }
2684             sv_catpvn(msg, ")", 1);
2685             SvREFCNT_dec(dirmsgsv);
2686             DIE("%_", msg);
2687         }
2688
2689         RETPUSHUNDEF;
2690     }
2691     else
2692         SETERRNO(0, SS$_NORMAL);
2693
2694     /* Assume success here to prevent recursive requirement. */
2695     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2696         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2697
2698     ENTER;
2699     SAVETMPS;
2700     lex_start(sv_2mortal(newSVpv("",0)));
2701     SAVEGENERICSV(PL_rsfp_filters);
2702     PL_rsfp_filters = Nullav;
2703
2704     PL_rsfp = tryrsfp;
2705     name = savepv(name);
2706     SAVEFREEPV(name);
2707     SAVEHINTS();
2708     PL_hints = 0;
2709     SAVEPPTR(PL_compiling.cop_warnings);
2710     PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2711                                                              : WARN_NONE);
2712
2713     /* switch to eval mode */
2714
2715     push_return(PL_op->op_next);
2716     PUSHBLOCK(cx, CXt_EVAL, SP);
2717     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2718
2719     SAVEI16(PL_compiling.cop_line);
2720     PL_compiling.cop_line = 0;
2721
2722     PUTBACK;
2723 #ifdef USE_THREADS
2724     MUTEX_LOCK(&PL_eval_mutex);
2725     if (PL_eval_owner && PL_eval_owner != thr)
2726         while (PL_eval_owner)
2727             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2728     PL_eval_owner = thr;
2729     MUTEX_UNLOCK(&PL_eval_mutex);
2730 #endif /* USE_THREADS */
2731     return DOCATCH(doeval(G_SCALAR, NULL));
2732 }
2733
2734 PP(pp_dofile)
2735 {
2736     return pp_require(ARGS);
2737 }
2738
2739 PP(pp_entereval)
2740 {
2741     djSP;
2742     register PERL_CONTEXT *cx;
2743     dPOPss;
2744     I32 gimme = GIMME_V, was = PL_sub_generation;
2745     char tmpbuf[TYPE_DIGITS(long) + 12];
2746     char *safestr;
2747     STRLEN len;
2748     OP *ret;
2749
2750     if (!SvPV(sv,len) || !len)
2751         RETPUSHUNDEF;
2752     TAINT_PROPER("eval");
2753
2754     ENTER;
2755     lex_start(sv);
2756     SAVETMPS;
2757
2758     /* switch to eval mode */
2759
2760     SAVESPTR(PL_compiling.cop_filegv);
2761     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2762     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2763     PL_compiling.cop_line = 1;
2764     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2765        deleting the eval's FILEGV from the stash before gv_check() runs
2766        (i.e. before run-time proper). To work around the coredump that
2767        ensues, we always turn GvMULTI_on for any globals that were
2768        introduced within evals. See force_ident(). GSAR 96-10-12 */
2769     safestr = savepv(tmpbuf);
2770     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2771     SAVEHINTS();
2772     PL_hints = PL_op->op_targ;
2773     SAVEPPTR(PL_compiling.cop_warnings);
2774     if (PL_compiling.cop_warnings != WARN_ALL
2775         && PL_compiling.cop_warnings != WARN_NONE){
2776         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2777         SAVEFREESV(PL_compiling.cop_warnings) ;
2778     }
2779
2780     push_return(PL_op->op_next);
2781     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2782     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2783
2784     /* prepare to compile string */
2785
2786     if (PERLDB_LINE && PL_curstash != PL_debstash)
2787         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2788     PUTBACK;
2789 #ifdef USE_THREADS
2790     MUTEX_LOCK(&PL_eval_mutex);
2791     if (PL_eval_owner && PL_eval_owner != thr)
2792         while (PL_eval_owner)
2793             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2794     PL_eval_owner = thr;
2795     MUTEX_UNLOCK(&PL_eval_mutex);
2796 #endif /* USE_THREADS */
2797     ret = doeval(gimme, NULL);
2798     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2799         && ret != PL_op->op_next) {     /* Successive compilation. */
2800         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2801     }
2802     return DOCATCH(ret);
2803 }
2804
2805 PP(pp_leaveeval)
2806 {
2807     djSP;
2808     register SV **mark;
2809     SV **newsp;
2810     PMOP *newpm;
2811     I32 gimme;
2812     register PERL_CONTEXT *cx;
2813     OP *retop;
2814     U8 save_flags = PL_op -> op_flags;
2815     I32 optype;
2816
2817     POPBLOCK(cx,newpm);
2818     POPEVAL(cx);
2819     retop = pop_return();
2820
2821     TAINT_NOT;
2822     if (gimme == G_VOID)
2823         MARK = newsp;
2824     else if (gimme == G_SCALAR) {
2825         MARK = newsp + 1;
2826         if (MARK <= SP) {
2827             if (SvFLAGS(TOPs) & SVs_TEMP)
2828                 *MARK = TOPs;
2829             else
2830                 *MARK = sv_mortalcopy(TOPs);
2831         }
2832         else {
2833             MEXTEND(mark,0);
2834             *MARK = &PL_sv_undef;
2835         }
2836     }
2837     else {
2838         /* in case LEAVE wipes old return values */
2839         for (mark = newsp + 1; mark <= SP; mark++) {
2840             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2841                 *mark = sv_mortalcopy(*mark);
2842                 TAINT_NOT;      /* Each item is independent */
2843             }
2844         }
2845     }
2846     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2847
2848     /*
2849      * Closures mentioned at top level of eval cannot be referenced
2850      * again, and their presence indirectly causes a memory leak.
2851      * (Note that the fact that compcv and friends are still set here
2852      * is, AFAIK, an accident.)  --Chip
2853      */
2854     if (AvFILLp(PL_comppad_name) >= 0) {
2855         SV **svp = AvARRAY(PL_comppad_name);
2856         I32 ix;
2857         for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
2858             SV *sv = svp[ix];
2859             if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
2860                 SvREFCNT_dec(sv);
2861                 svp[ix] = &PL_sv_undef;
2862
2863                 sv = PL_curpad[ix];
2864                 if (CvCLONE(sv)) {
2865                     SvREFCNT_dec(CvOUTSIDE(sv));
2866                     CvOUTSIDE(sv) = Nullcv;
2867                 }
2868                 else {
2869                     SvREFCNT_dec(sv);
2870                     sv = NEWSV(0,0);
2871                     SvPADTMP_on(sv);
2872                     PL_curpad[ix] = sv;
2873                 }
2874             }
2875         }
2876     }
2877
2878 #ifdef DEBUGGING
2879     assert(CvDEPTH(PL_compcv) == 1);
2880 #endif
2881     CvDEPTH(PL_compcv) = 0;
2882     lex_end();
2883
2884     if (optype == OP_REQUIRE &&
2885         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2886     {
2887         /* Unassume the success we assumed earlier. */
2888         char *name = cx->blk_eval.old_name;
2889         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
2890         retop = die("%s did not return a true value", name);
2891         /* die_where() did LEAVE, or we won't be here */
2892     }
2893     else {
2894         LEAVE;
2895         if (!(save_flags & OPf_SPECIAL))
2896             sv_setpv(ERRSV,"");
2897     }
2898
2899     RETURNOP(retop);
2900 }
2901
2902 PP(pp_entertry)
2903 {
2904     djSP;
2905     register PERL_CONTEXT *cx;
2906     I32 gimme = GIMME_V;
2907
2908     ENTER;
2909     SAVETMPS;
2910
2911     push_return(cLOGOP->op_other->op_next);
2912     PUSHBLOCK(cx, CXt_EVAL, SP);
2913     PUSHEVAL(cx, 0, 0);
2914     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
2915
2916     PL_in_eval = 1;
2917     sv_setpv(ERRSV,"");
2918     PUTBACK;
2919     return DOCATCH(PL_op->op_next);
2920 }
2921
2922 PP(pp_leavetry)
2923 {
2924     djSP;
2925     register SV **mark;
2926     SV **newsp;
2927     PMOP *newpm;
2928     I32 gimme;
2929     register PERL_CONTEXT *cx;
2930     I32 optype;
2931
2932     POPBLOCK(cx,newpm);
2933     POPEVAL(cx);
2934     pop_return();
2935
2936     TAINT_NOT;
2937     if (gimme == G_VOID)
2938         SP = newsp;
2939     else if (gimme == G_SCALAR) {
2940         MARK = newsp + 1;
2941         if (MARK <= SP) {
2942             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2943                 *MARK = TOPs;
2944             else
2945                 *MARK = sv_mortalcopy(TOPs);
2946         }
2947         else {
2948             MEXTEND(mark,0);
2949             *MARK = &PL_sv_undef;
2950         }
2951         SP = MARK;
2952     }
2953     else {
2954         /* in case LEAVE wipes old return values */
2955         for (mark = newsp + 1; mark <= SP; mark++) {
2956             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2957                 *mark = sv_mortalcopy(*mark);
2958                 TAINT_NOT;      /* Each item is independent */
2959             }
2960         }
2961     }
2962     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2963
2964     LEAVE;
2965     sv_setpv(ERRSV,"");
2966     RETURN;
2967 }
2968
2969 STATIC void
2970 doparseform(SV *sv)
2971 {
2972     STRLEN len;
2973     register char *s = SvPV_force(sv, len);
2974     register char *send = s + len;
2975     register char *base;
2976     register I32 skipspaces = 0;
2977     bool noblank;
2978     bool repeat;
2979     bool postspace = FALSE;
2980     U16 *fops;
2981     register U16 *fpc;
2982     U16 *linepc;
2983     register I32 arg;
2984     bool ischop;
2985
2986     if (len == 0)
2987         croak("Null picture in formline");
2988
2989     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
2990     fpc = fops;
2991
2992     if (s < send) {
2993         linepc = fpc;
2994         *fpc++ = FF_LINEMARK;
2995         noblank = repeat = FALSE;
2996         base = s;
2997     }
2998
2999     while (s <= send) {
3000         switch (*s++) {
3001         default:
3002             skipspaces = 0;
3003             continue;
3004
3005         case '~':
3006             if (*s == '~') {
3007                 repeat = TRUE;
3008                 *s = ' ';
3009             }
3010             noblank = TRUE;
3011             s[-1] = ' ';
3012             /* FALL THROUGH */
3013         case ' ': case '\t':
3014             skipspaces++;
3015             continue;
3016
3017         case '\n': case 0:
3018             arg = s - base;
3019             skipspaces++;
3020             arg -= skipspaces;
3021             if (arg) {
3022                 if (postspace)
3023                     *fpc++ = FF_SPACE;
3024                 *fpc++ = FF_LITERAL;
3025                 *fpc++ = arg;
3026             }
3027             postspace = FALSE;
3028             if (s <= send)
3029                 skipspaces--;
3030             if (skipspaces) {
3031                 *fpc++ = FF_SKIP;
3032                 *fpc++ = skipspaces;
3033             }
3034             skipspaces = 0;
3035             if (s <= send)
3036                 *fpc++ = FF_NEWLINE;
3037             if (noblank) {
3038                 *fpc++ = FF_BLANK;
3039                 if (repeat)
3040                     arg = fpc - linepc + 1;
3041                 else
3042                     arg = 0;
3043                 *fpc++ = arg;
3044             }
3045             if (s < send) {
3046                 linepc = fpc;
3047                 *fpc++ = FF_LINEMARK;
3048                 noblank = repeat = FALSE;
3049                 base = s;
3050             }
3051             else
3052                 s++;
3053             continue;
3054
3055         case '@':
3056         case '^':
3057             ischop = s[-1] == '^';
3058
3059             if (postspace) {
3060                 *fpc++ = FF_SPACE;
3061                 postspace = FALSE;
3062             }
3063             arg = (s - base) - 1;
3064             if (arg) {
3065                 *fpc++ = FF_LITERAL;
3066                 *fpc++ = arg;
3067             }
3068
3069             base = s - 1;
3070             *fpc++ = FF_FETCH;
3071             if (*s == '*') {
3072                 s++;
3073                 *fpc++ = 0;
3074                 *fpc++ = FF_LINEGLOB;
3075             }
3076             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3077                 arg = ischop ? 512 : 0;
3078                 base = s - 1;
3079                 while (*s == '#')
3080                     s++;
3081                 if (*s == '.') {
3082                     char *f;
3083                     s++;
3084                     f = s;
3085                     while (*s == '#')
3086                         s++;
3087                     arg |= 256 + (s - f);
3088                 }
3089                 *fpc++ = s - base;              /* fieldsize for FETCH */
3090                 *fpc++ = FF_DECIMAL;
3091                 *fpc++ = arg;
3092             }
3093             else {
3094                 I32 prespace = 0;
3095                 bool ismore = FALSE;
3096
3097                 if (*s == '>') {
3098                     while (*++s == '>') ;
3099                     prespace = FF_SPACE;
3100                 }
3101                 else if (*s == '|') {
3102                     while (*++s == '|') ;
3103                     prespace = FF_HALFSPACE;
3104                     postspace = TRUE;
3105                 }
3106                 else {
3107                     if (*s == '<')
3108                         while (*++s == '<') ;
3109                     postspace = TRUE;
3110                 }
3111                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3112                     s += 3;
3113                     ismore = TRUE;
3114                 }
3115                 *fpc++ = s - base;              /* fieldsize for FETCH */
3116
3117                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3118
3119                 if (prespace)
3120                     *fpc++ = prespace;
3121                 *fpc++ = FF_ITEM;
3122                 if (ismore)
3123                     *fpc++ = FF_MORE;
3124                 if (ischop)
3125                     *fpc++ = FF_CHOP;
3126             }
3127             base = s;
3128             skipspaces = 0;
3129             continue;
3130         }
3131     }
3132     *fpc++ = FF_END;
3133
3134     arg = fpc - fops;
3135     { /* need to jump to the next word */
3136         int z;
3137         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3138         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3139         s = SvPVX(sv) + SvCUR(sv) + z;
3140     }
3141     Copy(fops, s, arg, U16);
3142     Safefree(fops);
3143     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3144     SvCOMPILED_on(sv);
3145 }
3146
3147 /*
3148  * The rest of this file was derived from source code contributed
3149  * by Tom Horsley.
3150  *
3151  * NOTE: this code was derived from Tom Horsley's qsort replacement
3152  * and should not be confused with the original code.
3153  */
3154
3155 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3156
3157    Permission granted to distribute under the same terms as perl which are
3158    (briefly):
3159
3160     This program is free software; you can redistribute it and/or modify
3161     it under the terms of either:
3162
3163         a) the GNU General Public License as published by the Free
3164         Software Foundation; either version 1, or (at your option) any
3165         later version, or
3166
3167         b) the "Artistic License" which comes with this Kit.
3168
3169    Details on the perl license can be found in the perl source code which
3170    may be located via the www.perl.com web page.
3171
3172    This is the most wonderfulest possible qsort I can come up with (and
3173    still be mostly portable) My (limited) tests indicate it consistently
3174    does about 20% fewer calls to compare than does the qsort in the Visual
3175    C++ library, other vendors may vary.
3176
3177    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3178    others I invented myself (or more likely re-invented since they seemed
3179    pretty obvious once I watched the algorithm operate for a while).
3180
3181    Most of this code was written while watching the Marlins sweep the Giants
3182    in the 1997 National League Playoffs - no Braves fans allowed to use this
3183    code (just kidding :-).
3184
3185    I realize that if I wanted to be true to the perl tradition, the only
3186    comment in this file would be something like:
3187
3188    ...they shuffled back towards the rear of the line. 'No, not at the
3189    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3190
3191    However, I really needed to violate that tradition just so I could keep
3192    track of what happens myself, not to mention some poor fool trying to
3193    understand this years from now :-).
3194 */
3195
3196 /* ********************************************************** Configuration */
3197
3198 #ifndef QSORT_ORDER_GUESS
3199 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3200 #endif
3201
3202 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3203    future processing - a good max upper bound is log base 2 of memory size
3204    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3205    safely be smaller than that since the program is taking up some space and
3206    most operating systems only let you grab some subset of contiguous
3207    memory (not to mention that you are normally sorting data larger than
3208    1 byte element size :-).
3209 */
3210 #ifndef QSORT_MAX_STACK
3211 #define QSORT_MAX_STACK 32
3212 #endif
3213
3214 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3215    Anything bigger and we use qsort. If you make this too small, the qsort
3216    will probably break (or become less efficient), because it doesn't expect
3217    the middle element of a partition to be the same as the right or left -
3218    you have been warned).
3219 */
3220 #ifndef QSORT_BREAK_EVEN
3221 #define QSORT_BREAK_EVEN 6
3222 #endif
3223
3224 /* ************************************************************* Data Types */
3225
3226 /* hold left and right index values of a partition waiting to be sorted (the
3227    partition includes both left and right - right is NOT one past the end or
3228    anything like that).
3229 */
3230 struct partition_stack_entry {
3231    int left;
3232    int right;
3233 #ifdef QSORT_ORDER_GUESS
3234    int qsort_break_even;
3235 #endif
3236 };
3237
3238 /* ******************************************************* Shorthand Macros */
3239
3240 /* Note that these macros will be used from inside the qsort function where
3241    we happen to know that the variable 'elt_size' contains the size of an
3242    array element and the variable 'temp' points to enough space to hold a
3243    temp element and the variable 'array' points to the array being sorted
3244    and 'compare' is the pointer to the compare routine.
3245
3246    Also note that there are very many highly architecture specific ways
3247    these might be sped up, but this is simply the most generally portable
3248    code I could think of.
3249 */
3250
3251 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3252 */
3253 #ifdef PERL_OBJECT
3254 #define qsort_cmp(elt1, elt2) \
3255    ((this->*compare)(array[elt1], array[elt2]))
3256 #else
3257 #define qsort_cmp(elt1, elt2) \
3258    ((*compare)(array[elt1], array[elt2]))
3259 #endif
3260
3261 #ifdef QSORT_ORDER_GUESS
3262 #define QSORT_NOTICE_SWAP swapped++;
3263 #else
3264 #define QSORT_NOTICE_SWAP
3265 #endif
3266
3267 /* swaps contents of array elements elt1, elt2.
3268 */
3269 #define qsort_swap(elt1, elt2) \
3270    STMT_START { \
3271       QSORT_NOTICE_SWAP \
3272       temp = array[elt1]; \
3273       array[elt1] = array[elt2]; \
3274       array[elt2] = temp; \
3275    } STMT_END
3276
3277 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3278    elt3 and elt3 gets elt1.
3279 */
3280 #define qsort_rotate(elt1, elt2, elt3) \
3281    STMT_START { \
3282       QSORT_NOTICE_SWAP \
3283       temp = array[elt1]; \
3284       array[elt1] = array[elt2]; \
3285       array[elt2] = array[elt3]; \
3286       array[elt3] = temp; \
3287    } STMT_END
3288
3289 /* ************************************************************ Debug stuff */
3290
3291 #ifdef QSORT_DEBUG
3292
3293 static void
3294 break_here()
3295 {
3296    return; /* good place to set a breakpoint */
3297 }
3298
3299 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3300
3301 static void
3302 doqsort_all_asserts(
3303    void * array,
3304    size_t num_elts,
3305    size_t elt_size,
3306    int (*compare)(const void * elt1, const void * elt2),
3307    int pc_left, int pc_right, int u_left, int u_right)
3308 {
3309    int i;
3310
3311    qsort_assert(pc_left <= pc_right);
3312    qsort_assert(u_right < pc_left);
3313    qsort_assert(pc_right < u_left);
3314    for (i = u_right + 1; i < pc_left; ++i) {
3315       qsort_assert(qsort_cmp(i, pc_left) < 0);
3316    }
3317    for (i = pc_left; i < pc_right; ++i) {
3318       qsort_assert(qsort_cmp(i, pc_right) == 0);
3319    }
3320    for (i = pc_right + 1; i < u_left; ++i) {
3321       qsort_assert(qsort_cmp(pc_right, i) < 0);
3322    }
3323 }
3324
3325 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3326    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3327                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3328
3329 #else
3330
3331 #define qsort_assert(t) ((void)0)
3332
3333 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3334
3335 #endif
3336
3337 /* ****************************************************************** qsort */
3338
3339 STATIC void
3340 #ifdef PERL_OBJECT
3341 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3342 #else
3343 qsortsv(
3344    SV ** array,
3345    size_t num_elts,
3346    I32 (*compare)(SV *a, SV *b))
3347 #endif
3348 {
3349    register SV * temp;
3350
3351    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3352    int next_stack_entry = 0;
3353
3354    int part_left;
3355    int part_right;
3356 #ifdef QSORT_ORDER_GUESS
3357    int qsort_break_even;
3358    int swapped;
3359 #endif
3360
3361    /* Make sure we actually have work to do.
3362    */
3363    if (num_elts <= 1) {
3364       return;
3365    }
3366
3367    /* Setup the initial partition definition and fall into the sorting loop
3368    */
3369    part_left = 0;
3370    part_right = (int)(num_elts - 1);
3371 #ifdef QSORT_ORDER_GUESS
3372    qsort_break_even = QSORT_BREAK_EVEN;
3373 #else
3374 #define qsort_break_even QSORT_BREAK_EVEN
3375 #endif
3376    for ( ; ; ) {
3377       if ((part_right - part_left) >= qsort_break_even) {
3378          /* OK, this is gonna get hairy, so lets try to document all the
3379             concepts and abbreviations and variables and what they keep
3380             track of:
3381
3382             pc: pivot chunk - the set of array elements we accumulate in the
3383                 middle of the partition, all equal in value to the original
3384                 pivot element selected. The pc is defined by:
3385
3386                 pc_left - the leftmost array index of the pc
3387                 pc_right - the rightmost array index of the pc
3388
3389                 we start with pc_left == pc_right and only one element
3390                 in the pivot chunk (but it can grow during the scan).
3391
3392             u:  uncompared elements - the set of elements in the partition
3393                 we have not yet compared to the pivot value. There are two
3394                 uncompared sets during the scan - one to the left of the pc
3395                 and one to the right.
3396
3397                 u_right - the rightmost index of the left side's uncompared set
3398                 u_left - the leftmost index of the right side's uncompared set
3399
3400                 The leftmost index of the left sides's uncompared set
3401                 doesn't need its own variable because it is always defined
3402                 by the leftmost edge of the whole partition (part_left). The
3403                 same goes for the rightmost edge of the right partition
3404                 (part_right).
3405
3406                 We know there are no uncompared elements on the left once we
3407                 get u_right < part_left and no uncompared elements on the
3408                 right once u_left > part_right. When both these conditions
3409                 are met, we have completed the scan of the partition.
3410
3411                 Any elements which are between the pivot chunk and the
3412                 uncompared elements should be less than the pivot value on
3413                 the left side and greater than the pivot value on the right
3414                 side (in fact, the goal of the whole algorithm is to arrange
3415                 for that to be true and make the groups of less-than and
3416                 greater-then elements into new partitions to sort again).
3417
3418             As you marvel at the complexity of the code and wonder why it
3419             has to be so confusing. Consider some of the things this level
3420             of confusion brings:
3421
3422             Once I do a compare, I squeeze every ounce of juice out of it. I
3423             never do compare calls I don't have to do, and I certainly never
3424             do redundant calls.
3425
3426             I also never swap any elements unless I can prove there is a
3427             good reason. Many sort algorithms will swap a known value with
3428             an uncompared value just to get things in the right place (or
3429             avoid complexity :-), but that uncompared value, once it gets
3430             compared, may then have to be swapped again. A lot of the
3431             complexity of this code is due to the fact that it never swaps
3432             anything except compared values, and it only swaps them when the
3433             compare shows they are out of position.
3434          */
3435          int pc_left, pc_right;
3436          int u_right, u_left;
3437
3438          int s;
3439
3440          pc_left = ((part_left + part_right) / 2);
3441          pc_right = pc_left;
3442          u_right = pc_left - 1;
3443          u_left = pc_right + 1;
3444
3445          /* Qsort works best when the pivot value is also the median value
3446             in the partition (unfortunately you can't find the median value
3447             without first sorting :-), so to give the algorithm a helping
3448             hand, we pick 3 elements and sort them and use the median value
3449             of that tiny set as the pivot value.
3450
3451             Some versions of qsort like to use the left middle and right as
3452             the 3 elements to sort so they can insure the ends of the
3453             partition will contain values which will stop the scan in the
3454             compare loop, but when you have to call an arbitrarily complex
3455             routine to do a compare, its really better to just keep track of
3456             array index values to know when you hit the edge of the
3457             partition and avoid the extra compare. An even better reason to
3458             avoid using a compare call is the fact that you can drop off the
3459             edge of the array if someone foolishly provides you with an
3460             unstable compare function that doesn't always provide consistent
3461             results.
3462
3463             So, since it is simpler for us to compare the three adjacent
3464             elements in the middle of the partition, those are the ones we
3465             pick here (conveniently pointed at by u_right, pc_left, and
3466             u_left). The values of the left, center, and right elements
3467             are refered to as l c and r in the following comments.
3468          */
3469
3470 #ifdef QSORT_ORDER_GUESS
3471          swapped = 0;
3472 #endif
3473          s = qsort_cmp(u_right, pc_left);
3474          if (s < 0) {
3475             /* l < c */
3476             s = qsort_cmp(pc_left, u_left);
3477             /* if l < c, c < r - already in order - nothing to do */
3478             if (s == 0) {
3479                /* l < c, c == r - already in order, pc grows */
3480                ++pc_right;
3481                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3482             } else if (s > 0) {
3483                /* l < c, c > r - need to know more */
3484                s = qsort_cmp(u_right, u_left);
3485                if (s < 0) {
3486                   /* l < c, c > r, l < r - swap c & r to get ordered */
3487                   qsort_swap(pc_left, u_left);
3488                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3489                } else if (s == 0) {
3490                   /* l < c, c > r, l == r - swap c&r, grow pc */
3491                   qsort_swap(pc_left, u_left);
3492                   --pc_left;
3493                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3494                } else {
3495                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3496                   qsort_rotate(pc_left, u_right, u_left);
3497                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3498                }
3499             }
3500          } else if (s == 0) {
3501             /* l == c */
3502             s = qsort_cmp(pc_left, u_left);
3503             if (s < 0) {
3504                /* l == c, c < r - already in order, grow pc */
3505                --pc_left;
3506                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3507             } else if (s == 0) {
3508                /* l == c, c == r - already in order, grow pc both ways */
3509                --pc_left;
3510                ++pc_right;
3511                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3512             } else {
3513                /* l == c, c > r - swap l & r, grow pc */
3514                qsort_swap(u_right, u_left);
3515                ++pc_right;
3516                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3517             }
3518          } else {
3519             /* l > c */
3520             s = qsort_cmp(pc_left, u_left);
3521             if (s < 0) {
3522                /* l > c, c < r - need to know more */
3523                s = qsort_cmp(u_right, u_left);
3524                if (s < 0) {
3525                   /* l > c, c < r, l < r - swap l & c to get ordered */
3526                   qsort_swap(u_right, pc_left);
3527                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3528                } else if (s == 0) {
3529                   /* l > c, c < r, l == r - swap l & c, grow pc */
3530                   qsort_swap(u_right, pc_left);
3531                   ++pc_right;
3532                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3533                } else {
3534                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3535                   qsort_rotate(u_right, pc_left, u_left);
3536                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3537                }
3538             } else if (s == 0) {
3539                /* l > c, c == r - swap ends, grow pc */
3540                qsort_swap(u_right, u_left);
3541                --pc_left;
3542                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3543             } else {
3544                /* l > c, c > r - swap ends to get in order */
3545                qsort_swap(u_right, u_left);
3546                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3547             }
3548          }
3549          /* We now know the 3 middle elements have been compared and
3550             arranged in the desired order, so we can shrink the uncompared
3551             sets on both sides
3552          */
3553          --u_right;
3554          ++u_left;
3555          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3556
3557          /* The above massive nested if was the simple part :-). We now have
3558             the middle 3 elements ordered and we need to scan through the
3559             uncompared sets on either side, swapping elements that are on
3560             the wrong side or simply shuffling equal elements around to get
3561             all equal elements into the pivot chunk.
3562          */
3563
3564          for ( ; ; ) {
3565             int still_work_on_left;
3566             int still_work_on_right;
3567
3568             /* Scan the uncompared values on the left. If I find a value
3569                equal to the pivot value, move it over so it is adjacent to
3570                the pivot chunk and expand the pivot chunk. If I find a value
3571                less than the pivot value, then just leave it - its already
3572                on the correct side of the partition. If I find a greater
3573                value, then stop the scan.
3574             */
3575             while (still_work_on_left = (u_right >= part_left)) {
3576                s = qsort_cmp(u_right, pc_left);
3577                if (s < 0) {
3578                   --u_right;
3579                } else if (s == 0) {
3580                   --pc_left;
3581                   if (pc_left != u_right) {
3582                      qsort_swap(u_right, pc_left);
3583                   }
3584                   --u_right;
3585                } else {
3586                   break;
3587                }
3588                qsort_assert(u_right < pc_left);
3589                qsort_assert(pc_left <= pc_right);
3590                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3591                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3592             }
3593
3594             /* Do a mirror image scan of uncompared values on the right
3595             */
3596             while (still_work_on_right = (u_left <= part_right)) {
3597                s = qsort_cmp(pc_right, u_left);
3598                if (s < 0) {
3599                   ++u_left;
3600                } else if (s == 0) {
3601                   ++pc_right;
3602                   if (pc_right != u_left) {
3603                      qsort_swap(pc_right, u_left);
3604                   }
3605                   ++u_left;
3606                } else {
3607                   break;
3608                }
3609                qsort_assert(u_left > pc_right);
3610                qsort_assert(pc_left <= pc_right);
3611                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3612                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3613             }
3614
3615             if (still_work_on_left) {
3616                /* I know I have a value on the left side which needs to be
3617                   on the right side, but I need to know more to decide
3618                   exactly the best thing to do with it.
3619                */
3620                if (still_work_on_right) {
3621                   /* I know I have values on both side which are out of
3622                      position. This is a big win because I kill two birds
3623                      with one swap (so to speak). I can advance the
3624                      uncompared pointers on both sides after swapping both
3625                      of them into the right place.
3626                   */
3627                   qsort_swap(u_right, u_left);
3628                   --u_right;
3629                   ++u_left;
3630                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3631                } else {
3632                   /* I have an out of position value on the left, but the
3633                      right is fully scanned, so I "slide" the pivot chunk
3634                      and any less-than values left one to make room for the
3635                      greater value over on the right. If the out of position
3636                      value is immediately adjacent to the pivot chunk (there
3637                      are no less-than values), I can do that with a swap,
3638                      otherwise, I have to rotate one of the less than values
3639                      into the former position of the out of position value
3640                      and the right end of the pivot chunk into the left end
3641                      (got all that?).
3642                   */
3643                   --pc_left;
3644                   if (pc_left == u_right) {
3645                      qsort_swap(u_right, pc_right);
3646                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3647                   } else {
3648                      qsort_rotate(u_right, pc_left, pc_right);
3649                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3650                   }
3651                   --pc_right;
3652                   --u_right;
3653                }
3654             } else if (still_work_on_right) {
3655                /* Mirror image of complex case above: I have an out of
3656                   position value on the right, but the left is fully
3657                   scanned, so I need to shuffle things around to make room
3658                   for the right value on the left.
3659                */
3660                ++pc_right;
3661                if (pc_right == u_left) {
3662                   qsort_swap(u_left, pc_left);
3663                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3664                } else {
3665                   qsort_rotate(pc_right, pc_left, u_left);
3666                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3667                }
3668                ++pc_left;
3669                ++u_left;
3670             } else {
3671                /* No more scanning required on either side of partition,
3672                   break out of loop and figure out next set of partitions
3673                */
3674                break;
3675             }
3676          }
3677
3678          /* The elements in the pivot chunk are now in the right place. They
3679             will never move or be compared again. All I have to do is decide
3680             what to do with the stuff to the left and right of the pivot
3681             chunk.
3682
3683             Notes on the QSORT_ORDER_GUESS ifdef code:
3684
3685             1. If I just built these partitions without swapping any (or
3686                very many) elements, there is a chance that the elements are
3687                already ordered properly (being properly ordered will
3688                certainly result in no swapping, but the converse can't be
3689                proved :-).
3690
3691             2. A (properly written) insertion sort will run faster on
3692                already ordered data than qsort will.
3693
3694             3. Perhaps there is some way to make a good guess about
3695                switching to an insertion sort earlier than partition size 6
3696                (for instance - we could save the partition size on the stack
3697                and increase the size each time we find we didn't swap, thus
3698                switching to insertion sort earlier for partitions with a
3699                history of not swapping).
3700
3701             4. Naturally, if I just switch right away, it will make
3702                artificial benchmarks with pure ascending (or descending)
3703                data look really good, but is that a good reason in general?
3704                Hard to say...
3705          */
3706
3707 #ifdef QSORT_ORDER_GUESS
3708          if (swapped < 3) {
3709 #if QSORT_ORDER_GUESS == 1
3710             qsort_break_even = (part_right - part_left) + 1;
3711 #endif
3712 #if QSORT_ORDER_GUESS == 2
3713             qsort_break_even *= 2;
3714 #endif
3715 #if QSORT_ORDER_GUESS == 3
3716             int prev_break = qsort_break_even;
3717             qsort_break_even *= qsort_break_even;
3718             if (qsort_break_even < prev_break) {
3719                qsort_break_even = (part_right - part_left) + 1;
3720             }
3721 #endif
3722          } else {
3723             qsort_break_even = QSORT_BREAK_EVEN;
3724          }
3725 #endif
3726
3727          if (part_left < pc_left) {
3728             /* There are elements on the left which need more processing.
3729                Check the right as well before deciding what to do.
3730             */
3731             if (pc_right < part_right) {
3732                /* We have two partitions to be sorted. Stack the biggest one
3733                   and process the smallest one on the next iteration. This
3734                   minimizes the stack height by insuring that any additional
3735                   stack entries must come from the smallest partition which
3736                   (because it is smallest) will have the fewest
3737                   opportunities to generate additional stack entries.
3738                */
3739                if ((part_right - pc_right) > (pc_left - part_left)) {
3740                   /* stack the right partition, process the left */
3741                   partition_stack[next_stack_entry].left = pc_right + 1;
3742                   partition_stack[next_stack_entry].right = part_right;
3743 #ifdef QSORT_ORDER_GUESS
3744                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3745 #endif
3746                   part_right = pc_left - 1;
3747                } else {
3748                   /* stack the left partition, process the right */
3749                   partition_stack[next_stack_entry].left = part_left;
3750                   partition_stack[next_stack_entry].right = pc_left - 1;
3751 #ifdef QSORT_ORDER_GUESS
3752                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3753 #endif
3754                   part_left = pc_right + 1;
3755                }
3756                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3757                ++next_stack_entry;
3758             } else {
3759                /* The elements on the left are the only remaining elements
3760                   that need sorting, arrange for them to be processed as the
3761                   next partition.
3762                */
3763                part_right = pc_left - 1;
3764             }
3765          } else if (pc_right < part_right) {
3766             /* There is only one chunk on the right to be sorted, make it
3767                the new partition and loop back around.
3768             */
3769             part_left = pc_right + 1;
3770          } else {
3771             /* This whole partition wound up in the pivot chunk, so
3772                we need to get a new partition off the stack.
3773             */
3774             if (next_stack_entry == 0) {
3775                /* the stack is empty - we are done */
3776                break;
3777             }
3778             --next_stack_entry;
3779             part_left = partition_stack[next_stack_entry].left;
3780             part_right = partition_stack[next_stack_entry].right;
3781 #ifdef QSORT_ORDER_GUESS
3782             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3783 #endif
3784          }
3785       } else {
3786          /* This partition is too small to fool with qsort complexity, just
3787             do an ordinary insertion sort to minimize overhead.
3788          */
3789          int i;
3790          /* Assume 1st element is in right place already, and start checking
3791             at 2nd element to see where it should be inserted.
3792          */
3793          for (i = part_left + 1; i <= part_right; ++i) {
3794             int j;
3795             /* Scan (backwards - just in case 'i' is already in right place)
3796                through the elements already sorted to see if the ith element
3797                belongs ahead of one of them.
3798             */
3799             for (j = i - 1; j >= part_left; --j) {
3800                if (qsort_cmp(i, j) >= 0) {
3801                   /* i belongs right after j
3802                   */
3803                   break;
3804                }
3805             }
3806             ++j;
3807             if (j != i) {
3808                /* Looks like we really need to move some things
3809                */
3810                int k;
3811                temp = array[i];
3812                for (k = i - 1; k >= j; --k)
3813                   array[k + 1] = array[k];
3814                array[j] = temp;
3815             }
3816          }
3817
3818          /* That partition is now sorted, grab the next one, or get out
3819             of the loop if there aren't any more.
3820          */
3821
3822          if (next_stack_entry == 0) {
3823             /* the stack is empty - we are done */
3824             break;
3825          }
3826          --next_stack_entry;
3827          part_left = partition_stack[next_stack_entry].left;
3828          part_right = partition_stack[next_stack_entry].right;
3829 #ifdef QSORT_ORDER_GUESS
3830          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3831 #endif
3832       }
3833    }
3834
3835    /* Believe it or not, the array is sorted at this point! */
3836 }