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