pp_ctl.c

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