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