contrib/perl5/pp_ctl.c

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