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