pp_ctl.c

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