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         dTHR;
1732         /* First try all the kids at this level, since that's likeliest. */
1733         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1734             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1735                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1736                 return kid;
1737         }
1738         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1739             if (kid == lastgotoprobe)
1740                 continue;
1741             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1742                 (ops == opstack ||
1743                  (ops[-1]->op_type != OP_NEXTSTATE &&
1744                   ops[-1]->op_type != OP_DBSTATE)))
1745                 *ops++ = kid;
1746             if (o = dofindlabel(kid, label, ops, oplimit))
1747                 return o;
1748         }
1749     }
1750     *ops = 0;
1751     return 0;
1752 }
1753
1754 PP(pp_dump)
1755 {
1756     return pp_goto(ARGS);
1757     /*NOTREACHED*/
1758 }
1759
1760 PP(pp_goto)
1761 {
1762     djSP;
1763     OP *retop = 0;
1764     I32 ix;
1765     register PERL_CONTEXT *cx;
1766 #define GOTO_DEPTH 64
1767     OP *enterops[GOTO_DEPTH];
1768     char *label;
1769     int do_dump = (op->op_type == OP_DUMP);
1770
1771     label = 0;
1772     if (op->op_flags & OPf_STACKED) {
1773         SV *sv = POPs;
1774
1775         /* This egregious kludge implements goto &subroutine */
1776         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1777             I32 cxix;
1778             register PERL_CONTEXT *cx;
1779             CV* cv = (CV*)SvRV(sv);
1780             SV** mark;
1781             I32 items = 0;
1782             I32 oldsave;
1783
1784             if (!CvROOT(cv) && !CvXSUB(cv)) {
1785                 if (CvGV(cv)) {
1786                     SV *tmpstr = sv_newmortal();
1787                     gv_efullname3(tmpstr, CvGV(cv), Nullch);
1788                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1789                 }
1790                 DIE("Goto undefined subroutine");
1791             }
1792
1793             /* First do some returnish stuff. */
1794             cxix = dopoptosub(cxstack_ix);
1795             if (cxix < 0)
1796                 DIE("Can't goto subroutine outside a subroutine");
1797             if (cxix < cxstack_ix)
1798                 dounwind(cxix);
1799             TOPBLOCK(cx);
1800             if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1801                 DIE("Can't goto subroutine from an eval-string");
1802             mark = stack_sp;
1803             if (cx->cx_type == CXt_SUB &&
1804                 cx->blk_sub.hasargs) {   /* put @_ back onto stack */
1805                 AV* av = cx->blk_sub.argarray;
1806
1807                 items = AvFILLp(av) + 1;
1808                 stack_sp++;
1809                 EXTEND(stack_sp, items); /* @_ could have been extended. */
1810                 Copy(AvARRAY(av), stack_sp, items, SV*);
1811                 stack_sp += items;
1812 #ifndef USE_THREADS
1813                 SvREFCNT_dec(GvAV(defgv));
1814                 GvAV(defgv) = cx->blk_sub.savearray;
1815 #endif /* USE_THREADS */
1816                 AvREAL_off(av);
1817                 av_clear(av);
1818             }
1819             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
1820                 AV* av;
1821                 int i;
1822 #ifdef USE_THREADS
1823                 av = (AV*)curpad[0];
1824 #else
1825                 av = GvAV(defgv);
1826 #endif
1827                 items = AvFILLp(av) + 1;
1828                 stack_sp++;
1829                 EXTEND(stack_sp, items); /* @_ could have been extended. */
1830                 Copy(AvARRAY(av), stack_sp, items, SV*);
1831                 stack_sp += items;
1832             }
1833             if (cx->cx_type == CXt_SUB &&
1834                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1835                 SvREFCNT_dec(cx->blk_sub.cv);
1836             oldsave = scopestack[scopestack_ix - 1];
1837             LEAVE_SCOPE(oldsave);
1838
1839             /* Now do some callish stuff. */
1840             SAVETMPS;
1841             if (CvXSUB(cv)) {
1842                 if (CvOLDSTYLE(cv)) {
1843                     I32 (*fp3)_((int,int,int));
1844                     while (SP > mark) {
1845                         SP[1] = SP[0];
1846                         SP--;
1847                     }
1848                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1849                     items = (*fp3)(CvXSUBANY(cv).any_i32,
1850                                    mark - stack_base + 1,
1851                                    items);
1852                     SP = stack_base + items;
1853                 }
1854                 else {
1855                     SV **newsp;
1856                     I32 gimme;
1857
1858                     stack_sp--;         /* There is no cv arg. */
1859                     /* Push a mark for the start of arglist */
1860                     PUSHMARK(mark);
1861                     (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1862                     /* Pop the current context like a decent sub should */
1863                     POPBLOCK(cx, curpm);
1864                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1865                 }
1866                 LEAVE;
1867                 return pop_return();
1868             }
1869             else {
1870                 AV* padlist = CvPADLIST(cv);
1871                 SV** svp = AvARRAY(padlist);
1872                 if (cx->cx_type == CXt_EVAL) {
1873                     in_eval = cx->blk_eval.old_in_eval;
1874                     eval_root = cx->blk_eval.old_eval_root;
1875                     cx->cx_type = CXt_SUB;
1876                     cx->blk_sub.hasargs = 0;
1877                 }
1878                 cx->blk_sub.cv = cv;
1879                 cx->blk_sub.olddepth = CvDEPTH(cv);
1880                 CvDEPTH(cv)++;
1881                 if (CvDEPTH(cv) < 2)
1882                     (void)SvREFCNT_inc(cv);
1883                 else {  /* save temporaries on recursion? */
1884                     if (CvDEPTH(cv) == 100 && dowarn)
1885                         sub_crush_depth(cv);
1886                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
1887                         AV *newpad = newAV();
1888                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1889                         I32 ix = AvFILLp((AV*)svp[1]);
1890                         svp = AvARRAY(svp[0]);
1891                         for ( ;ix > 0; ix--) {
1892                             if (svp[ix] != &sv_undef) {
1893                                 char *name = SvPVX(svp[ix]);
1894                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1895                                     || *name == '&')
1896                                 {
1897                                     /* outer lexical or anon code */
1898                                     av_store(newpad, ix,
1899                                         SvREFCNT_inc(oldpad[ix]) );
1900                                 }
1901                                 else {          /* our own lexical */
1902                                     if (*name == '@')
1903                                         av_store(newpad, ix, sv = (SV*)newAV());
1904                                     else if (*name == '%')
1905                                         av_store(newpad, ix, sv = (SV*)newHV());
1906                                     else
1907                                         av_store(newpad, ix, sv = NEWSV(0,0));
1908                                     SvPADMY_on(sv);
1909                                 }
1910                             }
1911                             else {
1912                                 av_store(newpad, ix, sv = NEWSV(0,0));
1913                                 SvPADTMP_on(sv);
1914                             }
1915                         }
1916                         if (cx->blk_sub.hasargs) {
1917                             AV* av = newAV();
1918                             av_extend(av, 0);
1919                             av_store(newpad, 0, (SV*)av);
1920                             AvFLAGS(av) = AVf_REIFY;
1921                         }
1922                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1923                         AvFILLp(padlist) = CvDEPTH(cv);
1924                         svp = AvARRAY(padlist);
1925                     }
1926                 }
1927 #ifdef USE_THREADS
1928                 if (!cx->blk_sub.hasargs) {
1929                     AV* av = (AV*)curpad[0];
1930
1931                     items = AvFILLp(av) + 1;
1932                     if (items) {
1933                         /* Mark is at the end of the stack. */
1934                         EXTEND(SP, items);
1935                         Copy(AvARRAY(av), SP + 1, items, SV*);
1936                         SP += items;
1937                         PUTBACK ;
1938                     }
1939                 }
1940 #endif /* USE_THREADS */
1941                 SAVESPTR(curpad);
1942                 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1943 #ifndef USE_THREADS
1944                 if (cx->blk_sub.hasargs)
1945 #endif /* USE_THREADS */
1946                 {
1947                     AV* av = (AV*)curpad[0];
1948                     SV** ary;
1949
1950 #ifndef USE_THREADS
1951                     cx->blk_sub.savearray = GvAV(defgv);
1952                     GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1953 #endif /* USE_THREADS */
1954                     cx->blk_sub.argarray = av;
1955                     ++mark;
1956
1957                     if (items >= AvMAX(av) + 1) {
1958                         ary = AvALLOC(av);
1959                         if (AvARRAY(av) != ary) {
1960                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1961                             SvPVX(av) = (char*)ary;
1962                         }
1963                         if (items >= AvMAX(av) + 1) {
1964                             AvMAX(av) = items - 1;
1965                             Renew(ary,items+1,SV*);
1966                             AvALLOC(av) = ary;
1967                             SvPVX(av) = (char*)ary;
1968                         }
1969                     }
1970                     Copy(mark,AvARRAY(av),items,SV*);
1971                     AvFILLp(av) = items - 1;
1972
1973                     while (items--) {
1974                         if (*mark)
1975                             SvTEMP_off(*mark);
1976                         mark++;
1977                     }
1978                 }
1979                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
1980                     /*
1981                      * We do not care about using sv to call CV;
1982                      * it's for informational purposes only.
1983                      */
1984                     SV *sv = GvSV(DBsub);
1985                     CV *gotocv;
1986
1987                     if (PERLDB_SUB_NN) {
1988                         SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1989                     } else {
1990                         save_item(sv);
1991                         gv_efullname3(sv, CvGV(cv), Nullch);
1992                     }
1993                     if (  PERLDB_GOTO
1994                           && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1995                         PUSHMARK( stack_sp );
1996                         perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1997                         stack_sp--;
1998                     }
1999                 }
2000                 RETURNOP(CvSTART(cv));
2001             }
2002         }
2003         else
2004             label = SvPV(sv,na);
2005     }
2006     else if (op->op_flags & OPf_SPECIAL) {
2007         if (! do_dump)
2008             DIE("goto must have label");
2009     }
2010     else
2011         label = cPVOP->op_pv;
2012
2013     if (label && *label) {
2014         OP *gotoprobe = 0;
2015
2016         /* find label */
2017
2018         lastgotoprobe = 0;
2019         *enterops = 0;
2020         for (ix = cxstack_ix; ix >= 0; ix--) {
2021             cx = &cxstack[ix];
2022             switch (cx->cx_type) {
2023             case CXt_EVAL:
2024                 gotoprobe = eval_root; /* XXX not good for nested eval */
2025                 break;
2026             case CXt_LOOP:
2027                 gotoprobe = cx->blk_oldcop->op_sibling;
2028                 break;
2029             case CXt_SUBST:
2030                 continue;
2031             case CXt_BLOCK:
2032                 if (ix)
2033                     gotoprobe = cx->blk_oldcop->op_sibling;
2034                 else
2035                     gotoprobe = main_root;
2036                 break;
2037             case CXt_SUB:
2038                 if (CvDEPTH(cx->blk_sub.cv)) {
2039                     gotoprobe = CvROOT(cx->blk_sub.cv);
2040                     break;
2041                 }
2042                 /* FALL THROUGH */
2043             case CXt_NULL:
2044                 DIE("Can't \"goto\" outside a block");
2045             default:
2046                 if (ix)
2047                     DIE("panic: goto");
2048                 gotoprobe = main_root;
2049                 break;
2050             }
2051             retop = dofindlabel(gotoprobe, label,
2052                                 enterops, enterops + GOTO_DEPTH);
2053             if (retop)
2054                 break;
2055             lastgotoprobe = gotoprobe;
2056         }
2057         if (!retop)
2058             DIE("Can't find label %s", label);
2059
2060         /* pop unwanted frames */
2061
2062         if (ix < cxstack_ix) {
2063             I32 oldsave;
2064
2065             if (ix < 0)
2066                 ix = 0;
2067             dounwind(ix);
2068             TOPBLOCK(cx);
2069             oldsave = scopestack[scopestack_ix];
2070             LEAVE_SCOPE(oldsave);
2071         }
2072
2073         /* push wanted frames */
2074
2075         if (*enterops && enterops[1]) {
2076             OP *oldop = op;
2077             for (ix = 1; enterops[ix]; ix++) {
2078                 op = enterops[ix];
2079                 /* Eventually we may want to stack the needed arguments
2080                  * for each op.  For now, we punt on the hard ones. */
2081                 if (op->op_type == OP_ENTERITER)
2082                     DIE("Can't \"goto\" into the middle of a foreach loop",
2083                         label);
2084                 (CALLOP->op_ppaddr)(ARGS);
2085             }
2086             op = oldop;
2087         }
2088     }
2089
2090     if (do_dump) {
2091 #ifdef VMS
2092         if (!retop) retop = main_start;
2093 #endif
2094         restartop = retop;
2095         do_undump = TRUE;
2096
2097         my_unexec();
2098
2099         restartop = 0;          /* hmm, must be GNU unexec().. */
2100         do_undump = FALSE;
2101     }
2102
2103     if (top_env->je_prev) {
2104         restartop = retop;
2105         JMPENV_JUMP(3);
2106     }
2107
2108     RETURNOP(retop);
2109 }
2110
2111 PP(pp_exit)
2112 {
2113     djSP;
2114     I32 anum;
2115
2116     if (MAXARG < 1)
2117         anum = 0;
2118     else {
2119         anum = SvIVx(POPs);
2120 #ifdef VMSISH_EXIT
2121         if (anum == 1 && VMSISH_EXIT)
2122             anum = 0;
2123 #endif
2124     }
2125     my_exit(anum);
2126     PUSHs(&sv_undef);
2127     RETURN;
2128 }
2129
2130 #ifdef NOTYET
2131 PP(pp_nswitch)
2132 {
2133     djSP;
2134     double value = SvNVx(GvSV(cCOP->cop_gv));
2135     register I32 match = I_32(value);
2136
2137     if (value < 0.0) {
2138         if (((double)match) > value)
2139             --match;            /* was fractional--truncate other way */
2140     }
2141     match -= cCOP->uop.scop.scop_offset;
2142     if (match < 0)
2143         match = 0;
2144     else if (match > cCOP->uop.scop.scop_max)
2145         match = cCOP->uop.scop.scop_max;
2146     op = cCOP->uop.scop.scop_next[match];
2147     RETURNOP(op);
2148 }
2149
2150 PP(pp_cswitch)
2151 {
2152     djSP;
2153     register I32 match;
2154
2155     if (multiline)
2156         op = op->op_next;                       /* can't assume anything */
2157     else {
2158         match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2159         match -= cCOP->uop.scop.scop_offset;
2160         if (match < 0)
2161             match = 0;
2162         else if (match > cCOP->uop.scop.scop_max)
2163             match = cCOP->uop.scop.scop_max;
2164         op = cCOP->uop.scop.scop_next[match];
2165     }
2166     RETURNOP(op);
2167 }
2168 #endif
2169
2170 /* Eval. */
2171
2172 STATIC void
2173 save_lines(AV *array, SV *sv)
2174 {
2175     register char *s = SvPVX(sv);
2176     register char *send = SvPVX(sv) + SvCUR(sv);
2177     register char *t;
2178     register I32 line = 1;
2179
2180     while (s && s < send) {
2181         SV *tmpstr = NEWSV(85,0);
2182
2183         sv_upgrade(tmpstr, SVt_PVMG);
2184         t = strchr(s, '\n');
2185         if (t)
2186             t++;
2187         else
2188             t = send;
2189
2190         sv_setpvn(tmpstr, s, t - s);
2191         av_store(array, line++, tmpstr);
2192         s = t;
2193     }
2194 }
2195
2196 STATIC OP *
2197 docatch(OP *o)
2198 {
2199     dTHR;
2200     int ret;
2201     OP *oldop = op;
2202     dJMPENV;
2203
2204     op = o;
2205 #ifdef DEBUGGING
2206     assert(CATCH_GET == TRUE);
2207     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2208 #endif
2209     JMPENV_PUSH(ret);
2210     switch (ret) {
2211     default:                            /* topmost level handles it */
2212         JMPENV_POP;
2213         op = oldop;
2214         JMPENV_JUMP(ret);
2215         /* NOTREACHED */
2216     case 3:
2217         if (!restartop) {
2218             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2219             break;
2220         }
2221         op = restartop;
2222         restartop = 0;
2223         /* FALL THROUGH */
2224     case 0:
2225         CALLRUNOPS();
2226         break;
2227     }
2228     JMPENV_POP;
2229     op = oldop;
2230     return Nullop;
2231 }
2232
2233 OP *
2234 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2235 /* sv Text to convert to OP tree. */
2236 /* startop op_free() this to undo. */
2237 /* code Short string id of the caller. */
2238 {
2239     dSP;                                /* Make POPBLOCK work. */
2240     PERL_CONTEXT *cx;
2241     SV **newsp;
2242     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2243     I32 optype;
2244     OP dummy;
2245     OP *oop = op, *rop;
2246     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2247     char *safestr;
2248
2249     ENTER;
2250     lex_start(sv);
2251     SAVETMPS;
2252     /* switch to eval mode */
2253
2254     SAVESPTR(compiling.cop_filegv);
2255     SAVEI16(compiling.cop_line);
2256     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2257     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2258     compiling.cop_line = 1;
2259     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2260        deleting the eval's FILEGV from the stash before gv_check() runs
2261        (i.e. before run-time proper). To work around the coredump that
2262        ensues, we always turn GvMULTI_on for any globals that were
2263        introduced within evals. See force_ident(). GSAR 96-10-12 */
2264     safestr = savepv(tmpbuf);
2265     SAVEDELETE(defstash, safestr, strlen(safestr));
2266     SAVEHINTS();
2267 #ifdef OP_IN_REGISTER
2268     opsave = op;
2269 #else
2270     SAVEPPTR(op);
2271 #endif
2272     hints = 0;
2273
2274     op = &dummy;
2275     op->op_type = 0;                    /* Avoid uninit warning. */
2276     op->op_flags = 0;                   /* Avoid uninit warning. */
2277     PUSHBLOCK(cx, CXt_EVAL, SP);
2278     PUSHEVAL(cx, 0, compiling.cop_filegv);
2279     rop = doeval(G_SCALAR, startop);
2280     POPBLOCK(cx,curpm);
2281     POPEVAL(cx);
2282
2283     (*startop)->op_type = OP_NULL;
2284     (*startop)->op_ppaddr = ppaddr[OP_NULL];
2285     lex_end();
2286     *avp = (AV*)SvREFCNT_inc(comppad);
2287     LEAVE;
2288 #ifdef OP_IN_REGISTER
2289     op = opsave;
2290 #endif
2291     return rop;
2292 }
2293
2294 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2295 STATIC OP *
2296 doeval(int gimme, OP** startop)
2297 {
2298     dSP;
2299     OP *saveop = op;
2300     HV *newstash;
2301     CV *caller;
2302     AV* comppadlist;
2303     I32 i;
2304
2305     in_eval = 1;
2306
2307     PUSHMARK(SP);
2308
2309     /* set up a scratch pad */
2310
2311     SAVEI32(padix);
2312     SAVESPTR(curpad);
2313     SAVESPTR(comppad);
2314     SAVESPTR(comppad_name);
2315     SAVEI32(comppad_name_fill);
2316     SAVEI32(min_intro_pending);
2317     SAVEI32(max_intro_pending);
2318
2319     caller = compcv;
2320     for (i = cxstack_ix - 1; i >= 0; i--) {
2321         PERL_CONTEXT *cx = &cxstack[i];
2322         if (cx->cx_type == CXt_EVAL)
2323             break;
2324         else if (cx->cx_type == CXt_SUB) {
2325             caller = cx->blk_sub.cv;
2326             break;
2327         }
2328     }
2329
2330     SAVESPTR(compcv);
2331     compcv = (CV*)NEWSV(1104,0);
2332     sv_upgrade((SV *)compcv, SVt_PVCV);
2333     CvUNIQUE_on(compcv);
2334 #ifdef USE_THREADS
2335     CvOWNER(compcv) = 0;
2336     New(666, CvMUTEXP(compcv), 1, perl_mutex);
2337     MUTEX_INIT(CvMUTEXP(compcv));
2338 #endif /* USE_THREADS */
2339
2340     comppad = newAV();
2341     av_push(comppad, Nullsv);
2342     curpad = AvARRAY(comppad);
2343     comppad_name = newAV();
2344     comppad_name_fill = 0;
2345     min_intro_pending = 0;
2346     padix = 0;
2347 #ifdef USE_THREADS
2348     av_store(comppad_name, 0, newSVpv("@_", 2));
2349     curpad[0] = (SV*)newAV();
2350     SvPADMY_on(curpad[0]);      /* XXX Needed? */
2351 #endif /* USE_THREADS */
2352
2353     comppadlist = newAV();
2354     AvREAL_off(comppadlist);
2355     av_store(comppadlist, 0, (SV*)comppad_name);
2356     av_store(comppadlist, 1, (SV*)comppad);
2357     CvPADLIST(compcv) = comppadlist;
2358
2359     if (!saveop || saveop->op_type != OP_REQUIRE)
2360         CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2361
2362     SAVEFREESV(compcv);
2363
2364     /* make sure we compile in the right package */
2365
2366     newstash = curcop->cop_stash;
2367     if (curstash != newstash) {
2368         SAVESPTR(curstash);
2369         curstash = newstash;
2370     }
2371     SAVESPTR(beginav);
2372     beginav = newAV();
2373     SAVEFREESV(beginav);
2374
2375     /* try to compile it */
2376
2377     eval_root = Nullop;
2378     error_count = 0;
2379     curcop = &compiling;
2380     curcop->cop_arybase = 0;
2381     SvREFCNT_dec(rs);
2382     rs = newSVpv("\n", 1);
2383     if (saveop && saveop->op_flags & OPf_SPECIAL)
2384         in_eval |= 4;
2385     else
2386         sv_setpv(ERRSV,"");
2387     if (yyparse() || error_count || !eval_root) {
2388         SV **newsp;
2389         I32 gimme;
2390         PERL_CONTEXT *cx;
2391         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2392
2393         op = saveop;
2394         if (eval_root) {
2395             op_free(eval_root);
2396             eval_root = Nullop;
2397         }
2398         SP = stack_base + POPMARK;              /* pop original mark */
2399         if (!startop) {
2400             POPBLOCK(cx,curpm);
2401             POPEVAL(cx);
2402             pop_return();
2403         }
2404         lex_end();
2405         LEAVE;
2406         if (optype == OP_REQUIRE) {
2407             char* msg = SvPVx(ERRSV, na);
2408             DIE("%s", *msg ? msg : "Compilation failed in require");
2409         } else if (startop) {
2410             char* msg = SvPVx(ERRSV, na);
2411
2412             POPBLOCK(cx,curpm);
2413             POPEVAL(cx);
2414             croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2415         }
2416         SvREFCNT_dec(rs);
2417         rs = SvREFCNT_inc(nrs);
2418 #ifdef USE_THREADS
2419         MUTEX_LOCK(&eval_mutex);
2420         eval_owner = 0;
2421         COND_SIGNAL(&eval_cond);
2422         MUTEX_UNLOCK(&eval_mutex);
2423 #endif /* USE_THREADS */
2424         RETPUSHUNDEF;
2425     }
2426     SvREFCNT_dec(rs);
2427     rs = SvREFCNT_inc(nrs);
2428     compiling.cop_line = 0;
2429     if (startop) {
2430         *startop = eval_root;
2431         SvREFCNT_dec(CvOUTSIDE(compcv));
2432         CvOUTSIDE(compcv) = Nullcv;
2433     } else
2434         SAVEFREEOP(eval_root);
2435     if (gimme & G_VOID)
2436         scalarvoid(eval_root);
2437     else if (gimme & G_ARRAY)
2438         list(eval_root);
2439     else
2440         scalar(eval_root);
2441
2442     DEBUG_x(dump_eval());
2443
2444     /* Register with debugger: */
2445     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2446         CV *cv = perl_get_cv("DB::postponed", FALSE);
2447         if (cv) {
2448             dSP;
2449             PUSHMARK(SP);
2450             XPUSHs((SV*)compiling.cop_filegv);
2451             PUTBACK;
2452             perl_call_sv((SV*)cv, G_DISCARD);
2453         }
2454     }
2455
2456     /* compiled okay, so do it */
2457
2458     CvDEPTH(compcv) = 1;
2459     SP = stack_base + POPMARK;          /* pop original mark */
2460     op = saveop;                        /* The caller may need it. */
2461 #ifdef USE_THREADS
2462     MUTEX_LOCK(&eval_mutex);
2463     eval_owner = 0;
2464     COND_SIGNAL(&eval_cond);
2465     MUTEX_UNLOCK(&eval_mutex);
2466 #endif /* USE_THREADS */
2467
2468     RETURNOP(eval_start);
2469 }
2470
2471 PP(pp_require)
2472 {
2473     djSP;
2474     register PERL_CONTEXT *cx;
2475     SV *sv;
2476     char *name;
2477     STRLEN len;
2478     char *tryname;
2479     SV *namesv = Nullsv;
2480     SV** svp;
2481     I32 gimme = G_SCALAR;
2482     PerlIO *tryrsfp = 0;
2483
2484     sv = POPs;
2485     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2486         SET_NUMERIC_STANDARD();
2487         if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2488             DIE("Perl %s required--this is only version %s, stopped",
2489                 SvPV(sv,na),patchlevel);
2490         RETPUSHYES;
2491     }
2492     name = SvPV(sv, len);
2493     if (!(name && len > 0 && *name))
2494         DIE("Null filename used");
2495     TAINT_PROPER("require");
2496     if (op->op_type == OP_REQUIRE &&
2497       (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2498       *svp != &sv_undef)
2499         RETPUSHYES;
2500
2501     /* prepare to compile file */
2502
2503     if (*name == '/' ||
2504         (*name == '.' &&
2505             (name[1] == '/' ||
2506              (name[1] == '.' && name[2] == '/')))
2507 #ifdef DOSISH
2508       || (name[0] && name[1] == ':')
2509 #endif
2510 #ifdef WIN32
2511       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2512 #endif
2513 #ifdef VMS
2514         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2515             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2516 #endif
2517     )
2518     {
2519         tryname = name;
2520         tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2521     }
2522     else {
2523         AV *ar = GvAVn(incgv);
2524         I32 i;
2525 #ifdef VMS
2526         char *unixname;
2527         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2528 #endif
2529         {
2530             namesv = NEWSV(806, 0);
2531             for (i = 0; i <= AvFILL(ar); i++) {
2532                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2533 #ifdef VMS
2534                 char *unixdir;
2535                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2536                     continue;
2537                 sv_setpv(namesv, unixdir);
2538                 sv_catpv(namesv, unixname);
2539 #else
2540                 sv_setpvf(namesv, "%s/%s", dir, name);
2541 #endif
2542                 tryname = SvPVX(namesv);
2543                 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2544                 if (tryrsfp) {
2545                     if (tryname[0] == '.' && tryname[1] == '/')
2546                         tryname += 2;
2547                     break;
2548                 }
2549             }
2550         }
2551     }
2552     SAVESPTR(compiling.cop_filegv);
2553     compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2554     SvREFCNT_dec(namesv);
2555     if (!tryrsfp) {
2556         if (op->op_type == OP_REQUIRE) {
2557             SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2558             SV *dirmsgsv = NEWSV(0, 0);
2559             AV *ar = GvAVn(incgv);
2560             I32 i;
2561             if (instr(SvPVX(msg), ".h "))
2562                 sv_catpv(msg, " (change .h to .ph maybe?)");
2563             if (instr(SvPVX(msg), ".ph "))
2564                 sv_catpv(msg, " (did you run h2ph?)");
2565             sv_catpv(msg, " (@INC contains:");
2566             for (i = 0; i <= AvFILL(ar); i++) {
2567                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2568                 sv_setpvf(dirmsgsv, " %s", dir);
2569                 sv_catsv(msg, dirmsgsv);
2570             }
2571             sv_catpvn(msg, ")", 1);
2572             SvREFCNT_dec(dirmsgsv);
2573             DIE("%_", msg);
2574         }
2575
2576         RETPUSHUNDEF;
2577     }
2578
2579     /* Assume success here to prevent recursive requirement. */
2580     (void)hv_store(GvHVn(incgv), name, strlen(name),
2581         newSVsv(GvSV(compiling.cop_filegv)), 0 );
2582
2583     ENTER;
2584     SAVETMPS;
2585     lex_start(sv_2mortal(newSVpv("",0)));
2586     if (rsfp_filters){
2587         save_aptr(&rsfp_filters);
2588         rsfp_filters = NULL;
2589     }
2590
2591     rsfp = tryrsfp;
2592     name = savepv(name);
2593     SAVEFREEPV(name);
2594     SAVEHINTS();
2595     hints = 0;
2596
2597     /* switch to eval mode */
2598
2599     push_return(op->op_next);
2600     PUSHBLOCK(cx, CXt_EVAL, SP);
2601     PUSHEVAL(cx, name, compiling.cop_filegv);
2602
2603     compiling.cop_line = 0;
2604
2605     PUTBACK;
2606 #ifdef USE_THREADS
2607     MUTEX_LOCK(&eval_mutex);
2608     if (eval_owner && eval_owner != thr)
2609         while (eval_owner)
2610             COND_WAIT(&eval_cond, &eval_mutex);
2611     eval_owner = thr;
2612     MUTEX_UNLOCK(&eval_mutex);
2613 #endif /* USE_THREADS */
2614     return DOCATCH(doeval(G_SCALAR, NULL));
2615 }
2616
2617 PP(pp_dofile)
2618 {
2619     return pp_require(ARGS);
2620 }
2621
2622 PP(pp_entereval)
2623 {
2624     djSP;
2625     register PERL_CONTEXT *cx;
2626     dPOPss;
2627     I32 gimme = GIMME_V, was = sub_generation;
2628     char tmpbuf[TYPE_DIGITS(long) + 12];
2629     char *safestr;
2630     STRLEN len;
2631     OP *ret;
2632
2633     if (!SvPV(sv,len) || !len)
2634         RETPUSHUNDEF;
2635     TAINT_PROPER("eval");
2636
2637     ENTER;
2638     lex_start(sv);
2639     SAVETMPS;
2640
2641     /* switch to eval mode */
2642
2643     SAVESPTR(compiling.cop_filegv);
2644     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2645     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2646     compiling.cop_line = 1;
2647     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2648        deleting the eval's FILEGV from the stash before gv_check() runs
2649        (i.e. before run-time proper). To work around the coredump that
2650        ensues, we always turn GvMULTI_on for any globals that were
2651        introduced within evals. See force_ident(). GSAR 96-10-12 */
2652     safestr = savepv(tmpbuf);
2653     SAVEDELETE(defstash, safestr, strlen(safestr));
2654     SAVEHINTS();
2655     hints = op->op_targ;
2656
2657     push_return(op->op_next);
2658     PUSHBLOCK(cx, CXt_EVAL, SP);
2659     PUSHEVAL(cx, 0, compiling.cop_filegv);
2660
2661     /* prepare to compile string */
2662
2663     if (PERLDB_LINE && curstash != debstash)
2664         save_lines(GvAV(compiling.cop_filegv), linestr);
2665     PUTBACK;
2666 #ifdef USE_THREADS
2667     MUTEX_LOCK(&eval_mutex);
2668     if (eval_owner && eval_owner != thr)
2669         while (eval_owner)
2670             COND_WAIT(&eval_cond, &eval_mutex);
2671     eval_owner = thr;
2672     MUTEX_UNLOCK(&eval_mutex);
2673 #endif /* USE_THREADS */
2674     ret = doeval(gimme, NULL);
2675     if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2676         && ret != op->op_next) {        /* Successive compilation. */
2677         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2678     }
2679     return DOCATCH(ret);
2680 }
2681
2682 PP(pp_leaveeval)
2683 {
2684     djSP;
2685     register SV **mark;
2686     SV **newsp;
2687     PMOP *newpm;
2688     I32 gimme;
2689     register PERL_CONTEXT *cx;
2690     OP *retop;
2691     U8 save_flags = op -> op_flags;
2692     I32 optype;
2693
2694     POPBLOCK(cx,newpm);
2695     POPEVAL(cx);
2696     retop = pop_return();
2697
2698     TAINT_NOT;
2699     if (gimme == G_VOID)
2700         MARK = newsp;
2701     else if (gimme == G_SCALAR) {
2702         MARK = newsp + 1;
2703         if (MARK <= SP) {
2704             if (SvFLAGS(TOPs) & SVs_TEMP)
2705                 *MARK = TOPs;
2706             else
2707                 *MARK = sv_mortalcopy(TOPs);
2708         }
2709         else {
2710             MEXTEND(mark,0);
2711             *MARK = &sv_undef;
2712         }
2713     }
2714     else {
2715         /* in case LEAVE wipes old return values */
2716         for (mark = newsp + 1; mark <= SP; mark++) {
2717             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2718                 *mark = sv_mortalcopy(*mark);
2719                 TAINT_NOT;      /* Each item is independent */
2720             }
2721         }
2722     }
2723     curpm = newpm;      /* Don't pop $1 et al till now */
2724
2725     /*
2726      * Closures mentioned at top level of eval cannot be referenced
2727      * again, and their presence indirectly causes a memory leak.
2728      * (Note that the fact that compcv and friends are still set here
2729      * is, AFAIK, an accident.)  --Chip
2730      */
2731     if (AvFILLp(comppad_name) >= 0) {
2732         SV **svp = AvARRAY(comppad_name);
2733         I32 ix;
2734         for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2735             SV *sv = svp[ix];
2736             if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2737                 SvREFCNT_dec(sv);
2738                 svp[ix] = &sv_undef;
2739
2740                 sv = curpad[ix];
2741                 if (CvCLONE(sv)) {
2742                     SvREFCNT_dec(CvOUTSIDE(sv));
2743                     CvOUTSIDE(sv) = Nullcv;
2744                 }
2745                 else {
2746                     SvREFCNT_dec(sv);
2747                     sv = NEWSV(0,0);
2748                     SvPADTMP_on(sv);
2749                     curpad[ix] = sv;
2750                 }
2751             }
2752         }
2753     }
2754
2755 #ifdef DEBUGGING
2756     assert(CvDEPTH(compcv) == 1);
2757 #endif
2758     CvDEPTH(compcv) = 0;
2759     lex_end();
2760
2761     if (optype == OP_REQUIRE &&
2762         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2763     {
2764         /* Unassume the success we assumed earlier. */
2765         char *name = cx->blk_eval.old_name;
2766         (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2767         retop = die("%s did not return a true value", name);
2768         /* die_where() did LEAVE, or we won't be here */
2769     }
2770     else {
2771         LEAVE;
2772         if (!(save_flags & OPf_SPECIAL))
2773             sv_setpv(ERRSV,"");
2774     }
2775
2776     RETURNOP(retop);
2777 }
2778
2779 PP(pp_entertry)
2780 {
2781     djSP;
2782     register PERL_CONTEXT *cx;
2783     I32 gimme = GIMME_V;
2784
2785     ENTER;
2786     SAVETMPS;
2787
2788     push_return(cLOGOP->op_other->op_next);
2789     PUSHBLOCK(cx, CXt_EVAL, SP);
2790     PUSHEVAL(cx, 0, 0);
2791     eval_root = op;             /* Only needed so that goto works right. */
2792
2793     in_eval = 1;
2794     sv_setpv(ERRSV,"");
2795     PUTBACK;
2796     return DOCATCH(op->op_next);
2797 }
2798
2799 PP(pp_leavetry)
2800 {
2801     djSP;
2802     register SV **mark;
2803     SV **newsp;
2804     PMOP *newpm;
2805     I32 gimme;
2806     register PERL_CONTEXT *cx;
2807     I32 optype;
2808
2809     POPBLOCK(cx,newpm);
2810     POPEVAL(cx);
2811     pop_return();
2812
2813     TAINT_NOT;
2814     if (gimme == G_VOID)
2815         SP = newsp;
2816     else if (gimme == G_SCALAR) {
2817         MARK = newsp + 1;
2818         if (MARK <= SP) {
2819             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2820                 *MARK = TOPs;
2821             else
2822                 *MARK = sv_mortalcopy(TOPs);
2823         }
2824         else {
2825             MEXTEND(mark,0);
2826             *MARK = &sv_undef;
2827         }
2828         SP = MARK;
2829     }
2830     else {
2831         /* in case LEAVE wipes old return values */
2832         for (mark = newsp + 1; mark <= SP; mark++) {
2833             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2834                 *mark = sv_mortalcopy(*mark);
2835                 TAINT_NOT;      /* Each item is independent */
2836             }
2837         }
2838     }
2839     curpm = newpm;      /* Don't pop $1 et al till now */
2840
2841     LEAVE;
2842     sv_setpv(ERRSV,"");
2843     RETURN;
2844 }
2845
2846 STATIC void
2847 doparseform(SV *sv)
2848 {
2849     STRLEN len;
2850     register char *s = SvPV_force(sv, len);
2851     register char *send = s + len;
2852     register char *base;
2853     register I32 skipspaces = 0;
2854     bool noblank;
2855     bool repeat;
2856     bool postspace = FALSE;
2857     U16 *fops;
2858     register U16 *fpc;
2859     U16 *linepc;
2860     register I32 arg;
2861     bool ischop;
2862
2863     if (len == 0)
2864         croak("Null picture in formline");
2865
2866     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
2867     fpc = fops;
2868
2869     if (s < send) {
2870         linepc = fpc;
2871         *fpc++ = FF_LINEMARK;
2872         noblank = repeat = FALSE;
2873         base = s;
2874     }
2875
2876     while (s <= send) {
2877         switch (*s++) {
2878         default:
2879             skipspaces = 0;
2880             continue;
2881
2882         case '~':
2883             if (*s == '~') {
2884                 repeat = TRUE;
2885                 *s = ' ';
2886             }
2887             noblank = TRUE;
2888             s[-1] = ' ';
2889             /* FALL THROUGH */
2890         case ' ': case '\t':
2891             skipspaces++;
2892             continue;
2893
2894         case '\n': case 0:
2895             arg = s - base;
2896             skipspaces++;
2897             arg -= skipspaces;
2898             if (arg) {
2899                 if (postspace)
2900                     *fpc++ = FF_SPACE;
2901                 *fpc++ = FF_LITERAL;
2902                 *fpc++ = arg;
2903             }
2904             postspace = FALSE;
2905             if (s <= send)
2906                 skipspaces--;
2907             if (skipspaces) {
2908                 *fpc++ = FF_SKIP;
2909                 *fpc++ = skipspaces;
2910             }
2911             skipspaces = 0;
2912             if (s <= send)
2913                 *fpc++ = FF_NEWLINE;
2914             if (noblank) {
2915                 *fpc++ = FF_BLANK;
2916                 if (repeat)
2917                     arg = fpc - linepc + 1;
2918                 else
2919                     arg = 0;
2920                 *fpc++ = arg;
2921             }
2922             if (s < send) {
2923                 linepc = fpc;
2924                 *fpc++ = FF_LINEMARK;
2925                 noblank = repeat = FALSE;
2926                 base = s;
2927             }
2928             else
2929                 s++;
2930             continue;
2931
2932         case '@':
2933         case '^':
2934             ischop = s[-1] == '^';
2935
2936             if (postspace) {
2937                 *fpc++ = FF_SPACE;
2938                 postspace = FALSE;
2939             }
2940             arg = (s - base) - 1;
2941             if (arg) {
2942                 *fpc++ = FF_LITERAL;
2943                 *fpc++ = arg;
2944             }
2945
2946             base = s - 1;
2947             *fpc++ = FF_FETCH;
2948             if (*s == '*') {
2949                 s++;
2950                 *fpc++ = 0;
2951                 *fpc++ = FF_LINEGLOB;
2952             }
2953             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2954                 arg = ischop ? 512 : 0;
2955                 base = s - 1;
2956                 while (*s == '#')
2957                     s++;
2958                 if (*s == '.') {
2959                     char *f;
2960                     s++;
2961                     f = s;
2962                     while (*s == '#')
2963                         s++;
2964                     arg |= 256 + (s - f);
2965                 }
2966                 *fpc++ = s - base;              /* fieldsize for FETCH */
2967                 *fpc++ = FF_DECIMAL;
2968                 *fpc++ = arg;
2969             }
2970             else {
2971                 I32 prespace = 0;
2972                 bool ismore = FALSE;
2973
2974                 if (*s == '>') {
2975                     while (*++s == '>') ;
2976                     prespace = FF_SPACE;
2977                 }
2978                 else if (*s == '|') {
2979                     while (*++s == '|') ;
2980                     prespace = FF_HALFSPACE;
2981                     postspace = TRUE;
2982                 }
2983                 else {
2984                     if (*s == '<')
2985                         while (*++s == '<') ;
2986                     postspace = TRUE;
2987                 }
2988                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2989                     s += 3;
2990                     ismore = TRUE;
2991                 }
2992                 *fpc++ = s - base;              /* fieldsize for FETCH */
2993
2994                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2995
2996                 if (prespace)
2997                     *fpc++ = prespace;
2998                 *fpc++ = FF_ITEM;
2999                 if (ismore)
3000                     *fpc++ = FF_MORE;
3001                 if (ischop)
3002                     *fpc++ = FF_CHOP;
3003             }
3004             base = s;
3005             skipspaces = 0;
3006             continue;
3007         }
3008     }
3009     *fpc++ = FF_END;
3010
3011     arg = fpc - fops;
3012     { /* need to jump to the next word */
3013         int z;
3014         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3015         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3016         s = SvPVX(sv) + SvCUR(sv) + z;
3017     }
3018     Copy(fops, s, arg, U16);
3019     Safefree(fops);
3020     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3021     SvCOMPILED_on(sv);
3022 }
3023
3024 /*
3025  * The rest of this file was derived from source code contributed
3026  * by Tom Horsley.
3027  *
3028  * NOTE: this code was derived from Tom Horsley's qsort replacement
3029  * and should not be confused with the original code.
3030  */
3031
3032 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3033
3034    Permission granted to distribute under the same terms as perl which are
3035    (briefly):
3036
3037     This program is free software; you can redistribute it and/or modify
3038     it under the terms of either:
3039
3040         a) the GNU General Public License as published by the Free
3041         Software Foundation; either version 1, or (at your option) any
3042         later version, or
3043
3044         b) the "Artistic License" which comes with this Kit.
3045
3046    Details on the perl license can be found in the perl source code which
3047    may be located via the www.perl.com web page.
3048
3049    This is the most wonderfulest possible qsort I can come up with (and
3050    still be mostly portable) My (limited) tests indicate it consistently
3051    does about 20% fewer calls to compare than does the qsort in the Visual
3052    C++ library, other vendors may vary.
3053
3054    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3055    others I invented myself (or more likely re-invented since they seemed
3056    pretty obvious once I watched the algorithm operate for a while).
3057
3058    Most of this code was written while watching the Marlins sweep the Giants
3059    in the 1997 National League Playoffs - no Braves fans allowed to use this
3060    code (just kidding :-).
3061
3062    I realize that if I wanted to be true to the perl tradition, the only
3063    comment in this file would be something like:
3064
3065    ...they shuffled back towards the rear of the line. 'No, not at the
3066    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3067
3068    However, I really needed to violate that tradition just so I could keep
3069    track of what happens myself, not to mention some poor fool trying to
3070    understand this years from now :-).
3071 */
3072
3073 /* ********************************************************** Configuration */
3074
3075 #ifndef QSORT_ORDER_GUESS
3076 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3077 #endif
3078
3079 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3080    future processing - a good max upper bound is log base 2 of memory size
3081    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3082    safely be smaller than that since the program is taking up some space and
3083    most operating systems only let you grab some subset of contiguous
3084    memory (not to mention that you are normally sorting data larger than
3085    1 byte element size :-).
3086 */
3087 #ifndef QSORT_MAX_STACK
3088 #define QSORT_MAX_STACK 32
3089 #endif
3090
3091 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3092    Anything bigger and we use qsort. If you make this too small, the qsort
3093    will probably break (or become less efficient), because it doesn't expect
3094    the middle element of a partition to be the same as the right or left -
3095    you have been warned).
3096 */
3097 #ifndef QSORT_BREAK_EVEN
3098 #define QSORT_BREAK_EVEN 6
3099 #endif
3100
3101 /* ************************************************************* Data Types */
3102
3103 /* hold left and right index values of a partition waiting to be sorted (the
3104    partition includes both left and right - right is NOT one past the end or
3105    anything like that).
3106 */
3107 struct partition_stack_entry {
3108    int left;
3109    int right;
3110 #ifdef QSORT_ORDER_GUESS
3111    int qsort_break_even;
3112 #endif
3113 };
3114
3115 /* ******************************************************* Shorthand Macros */
3116
3117 /* Note that these macros will be used from inside the qsort function where
3118    we happen to know that the variable 'elt_size' contains the size of an
3119    array element and the variable 'temp' points to enough space to hold a
3120    temp element and the variable 'array' points to the array being sorted
3121    and 'compare' is the pointer to the compare routine.
3122
3123    Also note that there are very many highly architecture specific ways
3124    these might be sped up, but this is simply the most generally portable
3125    code I could think of.
3126 */
3127
3128 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3129 */
3130 #ifdef PERL_OBJECT
3131 #define qsort_cmp(elt1, elt2) \
3132    ((this->*compare)(array[elt1], array[elt2]))
3133 #else
3134 #define qsort_cmp(elt1, elt2) \
3135    ((*compare)(array[elt1], array[elt2]))
3136 #endif
3137
3138 #ifdef QSORT_ORDER_GUESS
3139 #define QSORT_NOTICE_SWAP swapped++;
3140 #else
3141 #define QSORT_NOTICE_SWAP
3142 #endif
3143
3144 /* swaps contents of array elements elt1, elt2.
3145 */
3146 #define qsort_swap(elt1, elt2) \
3147    STMT_START { \
3148       QSORT_NOTICE_SWAP \
3149       temp = array[elt1]; \
3150       array[elt1] = array[elt2]; \
3151       array[elt2] = temp; \
3152    } STMT_END
3153
3154 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3155    elt3 and elt3 gets elt1.
3156 */
3157 #define qsort_rotate(elt1, elt2, elt3) \
3158    STMT_START { \
3159       QSORT_NOTICE_SWAP \
3160       temp = array[elt1]; \
3161       array[elt1] = array[elt2]; \
3162       array[elt2] = array[elt3]; \
3163       array[elt3] = temp; \
3164    } STMT_END
3165
3166 /* ************************************************************ Debug stuff */
3167
3168 #ifdef QSORT_DEBUG
3169
3170 static void
3171 break_here()
3172 {
3173    return; /* good place to set a breakpoint */
3174 }
3175
3176 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3177
3178 static void
3179 doqsort_all_asserts(
3180    void * array,
3181    size_t num_elts,
3182    size_t elt_size,
3183    int (*compare)(const void * elt1, const void * elt2),
3184    int pc_left, int pc_right, int u_left, int u_right)
3185 {
3186    int i;
3187
3188    qsort_assert(pc_left <= pc_right);
3189    qsort_assert(u_right < pc_left);
3190    qsort_assert(pc_right < u_left);
3191    for (i = u_right + 1; i < pc_left; ++i) {
3192       qsort_assert(qsort_cmp(i, pc_left) < 0);
3193    }
3194    for (i = pc_left; i < pc_right; ++i) {
3195       qsort_assert(qsort_cmp(i, pc_right) == 0);
3196    }
3197    for (i = pc_right + 1; i < u_left; ++i) {
3198       qsort_assert(qsort_cmp(pc_right, i) < 0);
3199    }
3200 }
3201
3202 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3203    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3204                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3205
3206 #else
3207
3208 #define qsort_assert(t) ((void)0)
3209
3210 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3211
3212 #endif
3213
3214 /* ****************************************************************** qsort */
3215
3216 STATIC void
3217 #ifdef PERL_OBJECT
3218 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3219 #else
3220 qsortsv(
3221    SV ** array,
3222    size_t num_elts,
3223    I32 (*compare)(SV *a, SV *b))
3224 #endif
3225 {
3226    register SV * temp;
3227
3228    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3229    int next_stack_entry = 0;
3230
3231    int part_left;
3232    int part_right;
3233 #ifdef QSORT_ORDER_GUESS
3234    int qsort_break_even;
3235    int swapped;
3236 #endif
3237
3238    /* Make sure we actually have work to do.
3239    */
3240    if (num_elts <= 1) {
3241       return;
3242    }
3243
3244    /* Setup the initial partition definition and fall into the sorting loop
3245    */
3246    part_left = 0;
3247    part_right = (int)(num_elts - 1);
3248 #ifdef QSORT_ORDER_GUESS
3249    qsort_break_even = QSORT_BREAK_EVEN;
3250 #else
3251 #define qsort_break_even QSORT_BREAK_EVEN
3252 #endif
3253    for ( ; ; ) {
3254       if ((part_right - part_left) >= qsort_break_even) {
3255          /* OK, this is gonna get hairy, so lets try to document all the
3256             concepts and abbreviations and variables and what they keep
3257             track of:
3258
3259             pc: pivot chunk - the set of array elements we accumulate in the
3260                 middle of the partition, all equal in value to the original
3261                 pivot element selected. The pc is defined by:
3262
3263                 pc_left - the leftmost array index of the pc
3264                 pc_right - the rightmost array index of the pc
3265
3266                 we start with pc_left == pc_right and only one element
3267                 in the pivot chunk (but it can grow during the scan).
3268
3269             u:  uncompared elements - the set of elements in the partition
3270                 we have not yet compared to the pivot value. There are two
3271                 uncompared sets during the scan - one to the left of the pc
3272                 and one to the right.
3273
3274                 u_right - the rightmost index of the left side's uncompared set
3275                 u_left - the leftmost index of the right side's uncompared set
3276
3277                 The leftmost index of the left sides's uncompared set
3278                 doesn't need its own variable because it is always defined
3279                 by the leftmost edge of the whole partition (part_left). The
3280                 same goes for the rightmost edge of the right partition
3281                 (part_right).
3282
3283                 We know there are no uncompared elements on the left once we
3284                 get u_right < part_left and no uncompared elements on the
3285                 right once u_left > part_right. When both these conditions
3286                 are met, we have completed the scan of the partition.
3287
3288                 Any elements which are between the pivot chunk and the
3289                 uncompared elements should be less than the pivot value on
3290                 the left side and greater than the pivot value on the right
3291                 side (in fact, the goal of the whole algorithm is to arrange
3292                 for that to be true and make the groups of less-than and
3293                 greater-then elements into new partitions to sort again).
3294
3295             As you marvel at the complexity of the code and wonder why it
3296             has to be so confusing. Consider some of the things this level
3297             of confusion brings:
3298
3299             Once I do a compare, I squeeze every ounce of juice out of it. I
3300             never do compare calls I don't have to do, and I certainly never
3301             do redundant calls.
3302
3303             I also never swap any elements unless I can prove there is a
3304             good reason. Many sort algorithms will swap a known value with
3305             an uncompared value just to get things in the right place (or
3306             avoid complexity :-), but that uncompared value, once it gets
3307             compared, may then have to be swapped again. A lot of the
3308             complexity of this code is due to the fact that it never swaps
3309             anything except compared values, and it only swaps them when the
3310             compare shows they are out of position.
3311          */
3312          int pc_left, pc_right;
3313          int u_right, u_left;
3314
3315          int s;
3316
3317          pc_left = ((part_left + part_right) / 2);
3318          pc_right = pc_left;
3319          u_right = pc_left - 1;
3320          u_left = pc_right + 1;
3321
3322          /* Qsort works best when the pivot value is also the median value
3323             in the partition (unfortunately you can't find the median value
3324             without first sorting :-), so to give the algorithm a helping
3325             hand, we pick 3 elements and sort them and use the median value
3326             of that tiny set as the pivot value.
3327
3328             Some versions of qsort like to use the left middle and right as
3329             the 3 elements to sort so they can insure the ends of the
3330             partition will contain values which will stop the scan in the
3331             compare loop, but when you have to call an arbitrarily complex
3332             routine to do a compare, its really better to just keep track of
3333             array index values to know when you hit the edge of the
3334             partition and avoid the extra compare. An even better reason to
3335             avoid using a compare call is the fact that you can drop off the
3336             edge of the array if someone foolishly provides you with an
3337             unstable compare function that doesn't always provide consistent
3338             results.
3339
3340             So, since it is simpler for us to compare the three adjacent
3341             elements in the middle of the partition, those are the ones we
3342             pick here (conveniently pointed at by u_right, pc_left, and
3343             u_left). The values of the left, center, and right elements
3344             are refered to as l c and r in the following comments.
3345          */
3346
3347 #ifdef QSORT_ORDER_GUESS
3348          swapped = 0;
3349 #endif
3350          s = qsort_cmp(u_right, pc_left);
3351          if (s < 0) {
3352             /* l < c */
3353             s = qsort_cmp(pc_left, u_left);
3354             /* if l < c, c < r - already in order - nothing to do */
3355             if (s == 0) {
3356                /* l < c, c == r - already in order, pc grows */
3357                ++pc_right;
3358                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3359             } else if (s > 0) {
3360                /* l < c, c > r - need to know more */
3361                s = qsort_cmp(u_right, u_left);
3362                if (s < 0) {
3363                   /* l < c, c > r, l < r - swap c & r to get ordered */
3364                   qsort_swap(pc_left, u_left);
3365                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3366                } else if (s == 0) {
3367                   /* l < c, c > r, l == r - swap c&r, grow pc */
3368                   qsort_swap(pc_left, u_left);
3369                   --pc_left;
3370                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3371                } else {
3372                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3373                   qsort_rotate(pc_left, u_right, u_left);
3374                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3375                }
3376             }
3377          } else if (s == 0) {
3378             /* l == c */
3379             s = qsort_cmp(pc_left, u_left);
3380             if (s < 0) {
3381                /* l == c, c < r - already in order, grow pc */
3382                --pc_left;
3383                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3384             } else if (s == 0) {
3385                /* l == c, c == r - already in order, grow pc both ways */
3386                --pc_left;
3387                ++pc_right;
3388                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3389             } else {
3390                /* l == c, c > r - swap l & r, grow pc */
3391                qsort_swap(u_right, u_left);
3392                ++pc_right;
3393                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3394             }
3395          } else {
3396             /* l > c */
3397             s = qsort_cmp(pc_left, u_left);
3398             if (s < 0) {
3399                /* l > c, c < r - need to know more */
3400                s = qsort_cmp(u_right, u_left);
3401                if (s < 0) {
3402                   /* l > c, c < r, l < r - swap l & c to get ordered */
3403                   qsort_swap(u_right, pc_left);
3404                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3405                } else if (s == 0) {
3406                   /* l > c, c < r, l == r - swap l & c, grow pc */
3407                   qsort_swap(u_right, pc_left);
3408                   ++pc_right;
3409                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3410                } else {
3411                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3412                   qsort_rotate(u_right, pc_left, u_left);
3413                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3414                }
3415             } else if (s == 0) {
3416                /* l > c, c == r - swap ends, grow pc */
3417                qsort_swap(u_right, u_left);
3418                --pc_left;
3419                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3420             } else {
3421                /* l > c, c > r - swap ends to get in order */
3422                qsort_swap(u_right, u_left);
3423                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3424             }
3425          }
3426          /* We now know the 3 middle elements have been compared and
3427             arranged in the desired order, so we can shrink the uncompared
3428             sets on both sides
3429          */
3430          --u_right;
3431          ++u_left;
3432          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3433
3434          /* The above massive nested if was the simple part :-). We now have
3435             the middle 3 elements ordered and we need to scan through the
3436             uncompared sets on either side, swapping elements that are on
3437             the wrong side or simply shuffling equal elements around to get
3438             all equal elements into the pivot chunk.
3439          */
3440
3441          for ( ; ; ) {
3442             int still_work_on_left;
3443             int still_work_on_right;
3444
3445             /* Scan the uncompared values on the left. If I find a value
3446                equal to the pivot value, move it over so it is adjacent to
3447                the pivot chunk and expand the pivot chunk. If I find a value
3448                less than the pivot value, then just leave it - its already
3449                on the correct side of the partition. If I find a greater
3450                value, then stop the scan.
3451             */
3452             while (still_work_on_left = (u_right >= part_left)) {
3453                s = qsort_cmp(u_right, pc_left);
3454                if (s < 0) {
3455                   --u_right;
3456                } else if (s == 0) {
3457                   --pc_left;
3458                   if (pc_left != u_right) {
3459                      qsort_swap(u_right, pc_left);
3460                   }
3461                   --u_right;
3462                } else {
3463                   break;
3464                }
3465                qsort_assert(u_right < pc_left);
3466                qsort_assert(pc_left <= pc_right);
3467                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3468                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3469             }
3470
3471             /* Do a mirror image scan of uncompared values on the right
3472             */
3473             while (still_work_on_right = (u_left <= part_right)) {
3474                s = qsort_cmp(pc_right, u_left);
3475                if (s < 0) {
3476                   ++u_left;
3477                } else if (s == 0) {
3478                   ++pc_right;
3479                   if (pc_right != u_left) {
3480                      qsort_swap(pc_right, u_left);
3481                   }
3482                   ++u_left;
3483                } else {
3484                   break;
3485                }
3486                qsort_assert(u_left > pc_right);
3487                qsort_assert(pc_left <= pc_right);
3488                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3489                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3490             }
3491
3492             if (still_work_on_left) {
3493                /* I know I have a value on the left side which needs to be
3494                   on the right side, but I need to know more to decide
3495                   exactly the best thing to do with it.
3496                */
3497                if (still_work_on_right) {
3498                   /* I know I have values on both side which are out of
3499                      position. This is a big win because I kill two birds
3500                      with one swap (so to speak). I can advance the
3501                      uncompared pointers on both sides after swapping both
3502                      of them into the right place.
3503                   */
3504                   qsort_swap(u_right, u_left);
3505                   --u_right;
3506                   ++u_left;
3507                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3508                } else {
3509                   /* I have an out of position value on the left, but the
3510                      right is fully scanned, so I "slide" the pivot chunk
3511                      and any less-than values left one to make room for the
3512                      greater value over on the right. If the out of position
3513                      value is immediately adjacent to the pivot chunk (there
3514                      are no less-than values), I can do that with a swap,
3515                      otherwise, I have to rotate one of the less than values
3516                      into the former position of the out of position value
3517                      and the right end of the pivot chunk into the left end
3518                      (got all that?).
3519                   */
3520                   --pc_left;
3521                   if (pc_left == u_right) {
3522                      qsort_swap(u_right, pc_right);
3523                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3524                   } else {
3525                      qsort_rotate(u_right, pc_left, pc_right);
3526                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3527                   }
3528                   --pc_right;
3529                   --u_right;
3530                }
3531             } else if (still_work_on_right) {
3532                /* Mirror image of complex case above: I have an out of
3533                   position value on the right, but the left is fully
3534                   scanned, so I need to shuffle things around to make room
3535                   for the right value on the left.
3536                */
3537                ++pc_right;
3538                if (pc_right == u_left) {
3539                   qsort_swap(u_left, pc_left);
3540                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3541                } else {
3542                   qsort_rotate(pc_right, pc_left, u_left);
3543                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3544                }
3545                ++pc_left;
3546                ++u_left;
3547             } else {
3548                /* No more scanning required on either side of partition,
3549                   break out of loop and figure out next set of partitions
3550                */
3551                break;
3552             }
3553          }
3554
3555          /* The elements in the pivot chunk are now in the right place. They
3556             will never move or be compared again. All I have to do is decide
3557             what to do with the stuff to the left and right of the pivot
3558             chunk.
3559
3560             Notes on the QSORT_ORDER_GUESS ifdef code:
3561
3562             1. If I just built these partitions without swapping any (or
3563                very many) elements, there is a chance that the elements are
3564                already ordered properly (being properly ordered will
3565                certainly result in no swapping, but the converse can't be
3566                proved :-).
3567
3568             2. A (properly written) insertion sort will run faster on
3569                already ordered data than qsort will.
3570
3571             3. Perhaps there is some way to make a good guess about
3572                switching to an insertion sort earlier than partition size 6
3573                (for instance - we could save the partition size on the stack
3574                and increase the size each time we find we didn't swap, thus
3575                switching to insertion sort earlier for partitions with a
3576                history of not swapping).
3577
3578             4. Naturally, if I just switch right away, it will make
3579                artificial benchmarks with pure ascending (or descending)
3580                data look really good, but is that a good reason in general?
3581                Hard to say...
3582          */
3583
3584 #ifdef QSORT_ORDER_GUESS
3585          if (swapped < 3) {
3586 #if QSORT_ORDER_GUESS == 1
3587             qsort_break_even = (part_right - part_left) + 1;
3588 #endif
3589 #if QSORT_ORDER_GUESS == 2
3590             qsort_break_even *= 2;
3591 #endif
3592 #if QSORT_ORDER_GUESS == 3
3593             int prev_break = qsort_break_even;
3594             qsort_break_even *= qsort_break_even;
3595             if (qsort_break_even < prev_break) {
3596                qsort_break_even = (part_right - part_left) + 1;
3597             }
3598 #endif
3599          } else {
3600             qsort_break_even = QSORT_BREAK_EVEN;
3601          }
3602 #endif
3603
3604          if (part_left < pc_left) {
3605             /* There are elements on the left which need more processing.
3606                Check the right as well before deciding what to do.
3607             */
3608             if (pc_right < part_right) {
3609                /* We have two partitions to be sorted. Stack the biggest one
3610                   and process the smallest one on the next iteration. This
3611                   minimizes the stack height by insuring that any additional
3612                   stack entries must come from the smallest partition which
3613                   (because it is smallest) will have the fewest
3614                   opportunities to generate additional stack entries.
3615                */
3616                if ((part_right - pc_right) > (pc_left - part_left)) {
3617                   /* stack the right partition, process the left */
3618                   partition_stack[next_stack_entry].left = pc_right + 1;
3619                   partition_stack[next_stack_entry].right = part_right;
3620 #ifdef QSORT_ORDER_GUESS
3621                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3622 #endif
3623                   part_right = pc_left - 1;
3624                } else {
3625                   /* stack the left partition, process the right */
3626                   partition_stack[next_stack_entry].left = part_left;
3627                   partition_stack[next_stack_entry].right = pc_left - 1;
3628 #ifdef QSORT_ORDER_GUESS
3629                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3630 #endif
3631                   part_left = pc_right + 1;
3632                }
3633                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3634                ++next_stack_entry;
3635             } else {
3636                /* The elements on the left are the only remaining elements
3637                   that need sorting, arrange for them to be processed as the
3638                   next partition.
3639                */
3640                part_right = pc_left - 1;
3641             }
3642          } else if (pc_right < part_right) {
3643             /* There is only one chunk on the right to be sorted, make it
3644                the new partition and loop back around.
3645             */
3646             part_left = pc_right + 1;
3647          } else {
3648             /* This whole partition wound up in the pivot chunk, so
3649                we need to get a new partition off the stack.
3650             */
3651             if (next_stack_entry == 0) {
3652                /* the stack is empty - we are done */
3653                break;
3654             }
3655             --next_stack_entry;
3656             part_left = partition_stack[next_stack_entry].left;
3657             part_right = partition_stack[next_stack_entry].right;
3658 #ifdef QSORT_ORDER_GUESS
3659             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3660 #endif
3661          }
3662       } else {
3663          /* This partition is too small to fool with qsort complexity, just
3664             do an ordinary insertion sort to minimize overhead.
3665          */
3666          int i;
3667          /* Assume 1st element is in right place already, and start checking
3668             at 2nd element to see where it should be inserted.
3669          */
3670          for (i = part_left + 1; i <= part_right; ++i) {
3671             int j;
3672             /* Scan (backwards - just in case 'i' is already in right place)
3673                through the elements already sorted to see if the ith element
3674                belongs ahead of one of them.
3675             */
3676             for (j = i - 1; j >= part_left; --j) {
3677                if (qsort_cmp(i, j) >= 0) {
3678                   /* i belongs right after j
3679                   */
3680                   break;
3681                }
3682             }
3683             ++j;
3684             if (j != i) {
3685                /* Looks like we really need to move some things
3686                */
3687                int k;
3688                temp = array[i];
3689                for (k = i - 1; k >= j; --k)
3690                   array[k + 1] = array[k];
3691                array[j] = temp;
3692             }
3693          }
3694
3695          /* That partition is now sorted, grab the next one, or get out
3696             of the loop if there aren't any more.
3697          */
3698
3699          if (next_stack_entry == 0) {
3700             /* the stack is empty - we are done */
3701             break;
3702          }
3703          --next_stack_entry;
3704          part_left = partition_stack[next_stack_entry].left;
3705          part_right = partition_stack[next_stack_entry].right;
3706 #ifdef QSORT_ORDER_GUESS
3707          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3708 #endif
3709       }
3710    }
3711
3712    /* Believe it or not, the array is sorted at this point! */
3713 }