pp_ctl.c

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