pp_ctl.c

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