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