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