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