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