pp_ctl.c

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