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