pp_ctl.c

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