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         *ops = 0;
1920     }
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             {
1928                 return kid;
1929             }
1930         }
1931         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1932             if (kid == PL_lastgotoprobe)
1933                 continue;
1934             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1935                 && (ops == opstack || (ops[-1]->op_type != OP_NEXTSTATE
1936                                        && ops[-1]->op_type != OP_DBSTATE)))
1937             {
1938                 *ops++ = kid;
1939                 *ops = 0;
1940             }
1941             if (o = dofindlabel(kid, label, ops, oplimit))
1942                 return o;
1943         }
1944     }
1945     return 0;
1946 }
1947
1948 PP(pp_dump)
1949 {
1950     return pp_goto();
1951     /*NOTREACHED*/
1952 }
1953
1954 PP(pp_goto)
1955 {
1956     djSP;
1957     OP *retop = 0;
1958     I32 ix;
1959     register PERL_CONTEXT *cx;
1960 #define GOTO_DEPTH 64
1961     OP *enterops[GOTO_DEPTH];
1962     char *label;
1963     int do_dump = (PL_op->op_type == OP_DUMP);
1964     static char must_have_label[] = "goto must have label";
1965
1966     label = 0;
1967     if (PL_op->op_flags & OPf_STACKED) {
1968         SV *sv = POPs;
1969         STRLEN n_a;
1970
1971         /* This egregious kludge implements goto &subroutine */
1972         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1973             I32 cxix;
1974             register PERL_CONTEXT *cx;
1975             CV* cv = (CV*)SvRV(sv);
1976             SV** mark;
1977             I32 items = 0;
1978             I32 oldsave;
1979             int arg_was_real = 0;
1980
1981         retry:
1982             if (!CvROOT(cv) && !CvXSUB(cv)) {
1983                 GV *gv = CvGV(cv);
1984                 GV *autogv;
1985                 if (gv) {
1986                     SV *tmpstr;
1987                     /* autoloaded stub? */
1988                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
1989                         goto retry;
1990                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1991                                           GvNAMELEN(gv), FALSE);
1992                     if (autogv && (cv = GvCV(autogv)))
1993                         goto retry;
1994                     tmpstr = sv_newmortal();
1995                     gv_efullname3(tmpstr, gv, Nullch);
1996                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
1997                 }
1998                 DIE(aTHX_ "Goto undefined subroutine");
1999             }
2000
2001             /* First do some returnish stuff. */
2002             cxix = dopoptosub(cxstack_ix);
2003             if (cxix < 0)
2004                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2005             if (cxix < cxstack_ix)
2006                 dounwind(cxix);
2007             TOPBLOCK(cx);
2008             if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2009                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2010             mark = PL_stack_sp;
2011             if (CxTYPE(cx) == CXt_SUB &&
2012                 cx->blk_sub.hasargs) {   /* put @_ back onto stack */
2013                 AV* av = cx->blk_sub.argarray;
2014
2015                 items = AvFILLp(av) + 1;
2016                 PL_stack_sp++;
2017                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2018                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2019                 PL_stack_sp += items;
2020 #ifndef USE_THREADS
2021                 SvREFCNT_dec(GvAV(PL_defgv));
2022                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2023 #endif /* USE_THREADS */
2024                 if (AvREAL(av)) {
2025                     arg_was_real = 1;
2026                     AvREAL_off(av);     /* so av_clear() won't clobber elts */
2027                 }
2028                 av_clear(av);
2029             }
2030             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2031                 AV* av;
2032                 int i;
2033 #ifdef USE_THREADS
2034                 av = (AV*)PL_curpad[0];
2035 #else
2036                 av = GvAV(PL_defgv);
2037 #endif
2038                 items = AvFILLp(av) + 1;
2039                 PL_stack_sp++;
2040                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2041                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2042                 PL_stack_sp += items;
2043             }
2044             if (CxTYPE(cx) == CXt_SUB &&
2045                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2046                 SvREFCNT_dec(cx->blk_sub.cv);
2047             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2048             LEAVE_SCOPE(oldsave);
2049
2050             /* Now do some callish stuff. */
2051             SAVETMPS;
2052             if (CvXSUB(cv)) {
2053 #ifdef PERL_XSUB_OLDSTYLE
2054                 if (CvOLDSTYLE(cv)) {
2055                     I32 (*fp3)(int,int,int);
2056                     while (SP > mark) {
2057                         SP[1] = SP[0];
2058                         SP--;
2059                     }
2060                     fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
2061                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2062                                    mark - PL_stack_base + 1,
2063                                    items);
2064                     SP = PL_stack_base + items;
2065                 }
2066                 else
2067 #endif /* PERL_XSUB_OLDSTYLE */
2068                 {
2069                     SV **newsp;
2070                     I32 gimme;
2071
2072                     PL_stack_sp--;              /* There is no cv arg. */
2073                     /* Push a mark for the start of arglist */
2074                     PUSHMARK(mark);
2075                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2076                     /* Pop the current context like a decent sub should */
2077                     POPBLOCK(cx, PL_curpm);
2078                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2079                 }
2080                 LEAVE;
2081                 return pop_return();
2082             }
2083             else {
2084                 AV* padlist = CvPADLIST(cv);
2085                 SV** svp = AvARRAY(padlist);
2086                 if (CxTYPE(cx) == CXt_EVAL) {
2087                     PL_in_eval = cx->blk_eval.old_in_eval;
2088                     PL_eval_root = cx->blk_eval.old_eval_root;
2089                     cx->cx_type = CXt_SUB;
2090                     cx->blk_sub.hasargs = 0;
2091                 }
2092                 cx->blk_sub.cv = cv;
2093                 cx->blk_sub.olddepth = CvDEPTH(cv);
2094                 CvDEPTH(cv)++;
2095                 if (CvDEPTH(cv) < 2)
2096                     (void)SvREFCNT_inc(cv);
2097                 else {  /* save temporaries on recursion? */
2098                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2099                         sub_crush_depth(cv);
2100                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2101                         AV *newpad = newAV();
2102                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2103                         I32 ix = AvFILLp((AV*)svp[1]);
2104                         svp = AvARRAY(svp[0]);
2105                         for ( ;ix > 0; ix--) {
2106                             if (svp[ix] != &PL_sv_undef) {
2107                                 char *name = SvPVX(svp[ix]);
2108                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2109                                     || *name == '&')
2110                                 {
2111                                     /* outer lexical or anon code */
2112                                     av_store(newpad, ix,
2113                                         SvREFCNT_inc(oldpad[ix]) );
2114                                 }
2115                                 else {          /* our own lexical */
2116                                     if (*name == '@')
2117                                         av_store(newpad, ix, sv = (SV*)newAV());
2118                                     else if (*name == '%')
2119                                         av_store(newpad, ix, sv = (SV*)newHV());
2120                                     else
2121                                         av_store(newpad, ix, sv = NEWSV(0,0));
2122                                     SvPADMY_on(sv);
2123                                 }
2124                             }
2125                             else {
2126                                 av_store(newpad, ix, sv = NEWSV(0,0));
2127                                 SvPADTMP_on(sv);
2128                             }
2129                         }
2130                         if (cx->blk_sub.hasargs) {
2131                             AV* av = newAV();
2132                             av_extend(av, 0);
2133                             av_store(newpad, 0, (SV*)av);
2134                             AvFLAGS(av) = AVf_REIFY;
2135                         }
2136                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2137                         AvFILLp(padlist) = CvDEPTH(cv);
2138                         svp = AvARRAY(padlist);
2139                     }
2140                 }
2141 #ifdef USE_THREADS
2142                 if (!cx->blk_sub.hasargs) {
2143                     AV* av = (AV*)PL_curpad[0];
2144
2145                     items = AvFILLp(av) + 1;
2146                     if (items) {
2147                         /* Mark is at the end of the stack. */
2148                         EXTEND(SP, items);
2149                         Copy(AvARRAY(av), SP + 1, items, SV*);
2150                         SP += items;
2151                         PUTBACK ;
2152                     }
2153                 }
2154 #endif /* USE_THREADS */
2155                 SAVESPTR(PL_curpad);
2156                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2157 #ifndef USE_THREADS
2158                 if (cx->blk_sub.hasargs)
2159 #endif /* USE_THREADS */
2160                 {
2161                     AV* av = (AV*)PL_curpad[0];
2162                     SV** ary;
2163
2164 #ifndef USE_THREADS
2165                     cx->blk_sub.savearray = GvAV(PL_defgv);
2166                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2167 #endif /* USE_THREADS */
2168                     cx->blk_sub.argarray = av;
2169                     ++mark;
2170
2171                     if (items >= AvMAX(av) + 1) {
2172                         ary = AvALLOC(av);
2173                         if (AvARRAY(av) != ary) {
2174                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2175                             SvPVX(av) = (char*)ary;
2176                         }
2177                         if (items >= AvMAX(av) + 1) {
2178                             AvMAX(av) = items - 1;
2179                             Renew(ary,items+1,SV*);
2180                             AvALLOC(av) = ary;
2181                             SvPVX(av) = (char*)ary;
2182                         }
2183                     }
2184                     Copy(mark,AvARRAY(av),items,SV*);
2185                     AvFILLp(av) = items - 1;
2186                     /* preserve @_ nature */
2187                     if (arg_was_real) {
2188                         AvREIFY_off(av);
2189                         AvREAL_on(av);
2190                     }
2191                     while (items--) {
2192                         if (*mark)
2193                             SvTEMP_off(*mark);
2194                         mark++;
2195                     }
2196                 }
2197                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2198                     /*
2199                      * We do not care about using sv to call CV;
2200                      * it's for informational purposes only.
2201                      */
2202                     SV *sv = GvSV(PL_DBsub);
2203                     CV *gotocv;
2204
2205                     if (PERLDB_SUB_NN) {
2206                         SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2207                     } else {
2208                         save_item(sv);
2209                         gv_efullname3(sv, CvGV(cv), Nullch);
2210                     }
2211                     if (  PERLDB_GOTO
2212                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2213                         PUSHMARK( PL_stack_sp );
2214                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2215                         PL_stack_sp--;
2216                     }
2217                 }
2218                 RETURNOP(CvSTART(cv));
2219             }
2220         }
2221         else {
2222             label = SvPV(sv,n_a);
2223             if (!(do_dump || *label))
2224                 DIE(aTHX_ must_have_label);
2225         }
2226     }
2227     else if (PL_op->op_flags & OPf_SPECIAL) {
2228         if (! do_dump)
2229             DIE(aTHX_ must_have_label);
2230     }
2231     else
2232         label = cPVOP->op_pv;
2233
2234     if (label && *label) {
2235         OP *gotoprobe = 0;
2236
2237         /* find label */
2238
2239         PL_lastgotoprobe = 0;
2240         *enterops = 0;
2241         for (ix = cxstack_ix; ix >= 0; ix--) {
2242             cx = &cxstack[ix];
2243             switch (CxTYPE(cx)) {
2244             case CXt_EVAL:
2245                 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2246                 break;
2247             case CXt_LOOP:
2248                 gotoprobe = cx->blk_oldcop->op_sibling;
2249                 break;
2250             case CXt_SUBST:
2251                 continue;
2252             case CXt_BLOCK:
2253                 if (ix)
2254                     gotoprobe = cx->blk_oldcop->op_sibling;
2255                 else
2256                     gotoprobe = PL_main_root;
2257                 break;
2258             case CXt_SUB:
2259                 if (CvDEPTH(cx->blk_sub.cv)) {
2260                     gotoprobe = CvROOT(cx->blk_sub.cv);
2261                     break;
2262                 }
2263                 /* FALL THROUGH */
2264             case CXt_NULL:
2265                 DIE(aTHX_ "Can't \"goto\" outside a block");
2266             default:
2267                 if (ix)
2268                     DIE(aTHX_ "panic: goto");
2269                 gotoprobe = PL_main_root;
2270                 break;
2271             }
2272             retop = dofindlabel(gotoprobe, label,
2273                                 enterops, enterops + GOTO_DEPTH);
2274             if (retop)
2275                 break;
2276             PL_lastgotoprobe = gotoprobe;
2277         }
2278         if (!retop)
2279             DIE(aTHX_ "Can't find label %s", label);
2280
2281         /* pop unwanted frames */
2282
2283         if (ix < cxstack_ix) {
2284             I32 oldsave;
2285
2286             if (ix < 0)
2287                 ix = 0;
2288             dounwind(ix);
2289             TOPBLOCK(cx);
2290             oldsave = PL_scopestack[PL_scopestack_ix];
2291             LEAVE_SCOPE(oldsave);
2292         }
2293
2294         /* push wanted frames */
2295
2296         if (*enterops && enterops[1]) {
2297             OP *oldop = PL_op;
2298             for (ix = 1; enterops[ix]; ix++) {
2299                 PL_op = enterops[ix];
2300                 /* Eventually we may want to stack the needed arguments
2301                  * for each op.  For now, we punt on the hard ones. */
2302                 if (PL_op->op_type == OP_ENTERITER)
2303                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
2304                         label);
2305                 (CALLOP->op_ppaddr)(aTHX);
2306             }
2307             PL_op = oldop;
2308         }
2309     }
2310
2311     if (do_dump) {
2312 #ifdef VMS
2313         if (!retop) retop = PL_main_start;
2314 #endif
2315         PL_restartop = retop;
2316         PL_do_undump = TRUE;
2317
2318         my_unexec();
2319
2320         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2321         PL_do_undump = FALSE;
2322     }
2323
2324     RETURNOP(retop);
2325 }
2326
2327 PP(pp_exit)
2328 {
2329     djSP;
2330     I32 anum;
2331
2332     if (MAXARG < 1)
2333         anum = 0;
2334     else {
2335         anum = SvIVx(POPs);
2336 #ifdef VMSISH_EXIT
2337         if (anum == 1 && VMSISH_EXIT)
2338             anum = 0;
2339 #endif
2340     }
2341     my_exit(anum);
2342     PUSHs(&PL_sv_undef);
2343     RETURN;
2344 }
2345
2346 #ifdef NOTYET
2347 PP(pp_nswitch)
2348 {
2349     djSP;
2350     NV value = SvNVx(GvSV(cCOP->cop_gv));
2351     register I32 match = I_32(value);
2352
2353     if (value < 0.0) {
2354         if (((NV)match) > value)
2355             --match;            /* was fractional--truncate other way */
2356     }
2357     match -= cCOP->uop.scop.scop_offset;
2358     if (match < 0)
2359         match = 0;
2360     else if (match > cCOP->uop.scop.scop_max)
2361         match = cCOP->uop.scop.scop_max;
2362     PL_op = cCOP->uop.scop.scop_next[match];
2363     RETURNOP(PL_op);
2364 }
2365
2366 PP(pp_cswitch)
2367 {
2368     djSP;
2369     register I32 match;
2370
2371     if (PL_multiline)
2372         PL_op = PL_op->op_next;                 /* can't assume anything */
2373     else {
2374         STRLEN n_a;
2375         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2376         match -= cCOP->uop.scop.scop_offset;
2377         if (match < 0)
2378             match = 0;
2379         else if (match > cCOP->uop.scop.scop_max)
2380             match = cCOP->uop.scop.scop_max;
2381         PL_op = cCOP->uop.scop.scop_next[match];
2382     }
2383     RETURNOP(PL_op);
2384 }
2385 #endif
2386
2387 /* Eval. */
2388
2389 STATIC void
2390 S_save_lines(pTHX_ AV *array, SV *sv)
2391 {
2392     register char *s = SvPVX(sv);
2393     register char *send = SvPVX(sv) + SvCUR(sv);
2394     register char *t;
2395     register I32 line = 1;
2396
2397     while (s && s < send) {
2398         SV *tmpstr = NEWSV(85,0);
2399
2400         sv_upgrade(tmpstr, SVt_PVMG);
2401         t = strchr(s, '\n');
2402         if (t)
2403             t++;
2404         else
2405             t = send;
2406
2407         sv_setpvn(tmpstr, s, t - s);
2408         av_store(array, line++, tmpstr);
2409         s = t;
2410     }
2411 }
2412
2413 STATIC void *
2414 S_docatch_body(pTHX_ va_list args)
2415 {
2416     CALLRUNOPS(aTHX);
2417     return NULL;
2418 }
2419
2420 STATIC OP *
2421 S_docatch(pTHX_ OP *o)
2422 {
2423     dTHR;
2424     int ret;
2425     OP *oldop = PL_op;
2426
2427 #ifdef DEBUGGING
2428     assert(CATCH_GET == TRUE);
2429 #endif
2430     PL_op = o;
2431  redo_body:
2432     CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body));
2433     switch (ret) {
2434     case 0:
2435         break;
2436     case 3:
2437         if (PL_restartop) {
2438             PL_op = PL_restartop;
2439             PL_restartop = 0;
2440             goto redo_body;
2441         }
2442         /* FALL THROUGH */
2443     default:
2444         PL_op = oldop;
2445         JMPENV_JUMP(ret);
2446         /* NOTREACHED */
2447     }
2448     PL_op = oldop;
2449     return Nullop;
2450 }
2451
2452 OP *
2453 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2454 /* sv Text to convert to OP tree. */
2455 /* startop op_free() this to undo. */
2456 /* code Short string id of the caller. */
2457 {
2458     dSP;                                /* Make POPBLOCK work. */
2459     PERL_CONTEXT *cx;
2460     SV **newsp;
2461     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2462     I32 optype;
2463     OP dummy;
2464     OP *oop = PL_op, *rop;
2465     char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2466     char *safestr;
2467
2468     ENTER;
2469     lex_start(sv);
2470     SAVETMPS;
2471     /* switch to eval mode */
2472
2473     if (PL_curcop == &PL_compiling) {
2474         SAVESPTR(PL_compiling.cop_stash);
2475         PL_compiling.cop_stash = PL_curstash;
2476     }
2477     SAVESPTR(PL_compiling.cop_filegv);
2478     SAVEI16(PL_compiling.cop_line);
2479     sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2480     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2481     PL_compiling.cop_line = 1;
2482     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2483        deleting the eval's FILEGV from the stash before gv_check() runs
2484        (i.e. before run-time proper). To work around the coredump that
2485        ensues, we always turn GvMULTI_on for any globals that were
2486        introduced within evals. See force_ident(). GSAR 96-10-12 */
2487     safestr = savepv(tmpbuf);
2488     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2489     SAVEHINTS();
2490 #ifdef OP_IN_REGISTER
2491     PL_opsave = op;
2492 #else
2493     SAVEPPTR(PL_op);
2494 #endif
2495     PL_hints = 0;
2496
2497     PL_op = &dummy;
2498     PL_op->op_type = OP_ENTEREVAL;
2499     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2500     PUSHBLOCK(cx, CXt_EVAL, SP);
2501     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2502     rop = doeval(G_SCALAR, startop);
2503     POPBLOCK(cx,PL_curpm);
2504     POPEVAL(cx);
2505
2506     (*startop)->op_type = OP_NULL;
2507     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2508     lex_end();
2509     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2510     LEAVE;
2511     if (PL_curcop == &PL_compiling)
2512         PL_compiling.op_private = PL_hints;
2513 #ifdef OP_IN_REGISTER
2514     op = PL_opsave;
2515 #endif
2516     return rop;
2517 }
2518
2519 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2520 STATIC OP *
2521 S_doeval(pTHX_ int gimme, OP** startop)
2522 {
2523     dSP;
2524     OP *saveop = PL_op;
2525     HV *newstash;
2526     CV *caller;
2527     AV* comppadlist;
2528     I32 i;
2529
2530     PL_in_eval = EVAL_INEVAL;
2531
2532     PUSHMARK(SP);
2533
2534     /* set up a scratch pad */
2535
2536     SAVEI32(PL_padix);
2537     SAVESPTR(PL_curpad);
2538     SAVESPTR(PL_comppad);
2539     SAVESPTR(PL_comppad_name);
2540     SAVEI32(PL_comppad_name_fill);
2541     SAVEI32(PL_min_intro_pending);
2542     SAVEI32(PL_max_intro_pending);
2543
2544     caller = PL_compcv;
2545     for (i = cxstack_ix - 1; i >= 0; i--) {
2546         PERL_CONTEXT *cx = &cxstack[i];
2547         if (CxTYPE(cx) == CXt_EVAL)
2548             break;
2549         else if (CxTYPE(cx) == CXt_SUB) {
2550             caller = cx->blk_sub.cv;
2551             break;
2552         }
2553     }
2554
2555     SAVESPTR(PL_compcv);
2556     PL_compcv = (CV*)NEWSV(1104,0);
2557     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2558     CvEVAL_on(PL_compcv);
2559 #ifdef USE_THREADS
2560     CvOWNER(PL_compcv) = 0;
2561     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2562     MUTEX_INIT(CvMUTEXP(PL_compcv));
2563 #endif /* USE_THREADS */
2564
2565     PL_comppad = newAV();
2566     av_push(PL_comppad, Nullsv);
2567     PL_curpad = AvARRAY(PL_comppad);
2568     PL_comppad_name = newAV();
2569     PL_comppad_name_fill = 0;
2570     PL_min_intro_pending = 0;
2571     PL_padix = 0;
2572 #ifdef USE_THREADS
2573     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2574     PL_curpad[0] = (SV*)newAV();
2575     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2576 #endif /* USE_THREADS */
2577
2578     comppadlist = newAV();
2579     AvREAL_off(comppadlist);
2580     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2581     av_store(comppadlist, 1, (SV*)PL_comppad);
2582     CvPADLIST(PL_compcv) = comppadlist;
2583
2584     if (!saveop || saveop->op_type != OP_REQUIRE)
2585         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2586
2587     SAVEFREESV(PL_compcv);
2588
2589     /* make sure we compile in the right package */
2590
2591     newstash = PL_curcop->cop_stash;
2592     if (PL_curstash != newstash) {
2593         SAVESPTR(PL_curstash);
2594         PL_curstash = newstash;
2595     }
2596     SAVESPTR(PL_beginav);
2597     PL_beginav = newAV();
2598     SAVEFREESV(PL_beginav);
2599
2600     /* try to compile it */
2601
2602     PL_eval_root = Nullop;
2603     PL_error_count = 0;
2604     PL_curcop = &PL_compiling;
2605     PL_curcop->cop_arybase = 0;
2606     SvREFCNT_dec(PL_rs);
2607     PL_rs = newSVpvn("\n", 1);
2608     if (saveop && saveop->op_flags & OPf_SPECIAL)
2609         PL_in_eval |= EVAL_KEEPERR;
2610     else
2611         sv_setpv(ERRSV,"");
2612     if (yyparse() || PL_error_count || !PL_eval_root) {
2613         SV **newsp;
2614         I32 gimme;
2615         PERL_CONTEXT *cx;
2616         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2617         STRLEN n_a;
2618
2619         PL_op = saveop;
2620         if (PL_eval_root) {
2621             op_free(PL_eval_root);
2622             PL_eval_root = Nullop;
2623         }
2624         SP = PL_stack_base + POPMARK;           /* pop original mark */
2625         if (!startop) {
2626             POPBLOCK(cx,PL_curpm);
2627             POPEVAL(cx);
2628             pop_return();
2629         }
2630         lex_end();
2631         LEAVE;
2632         if (optype == OP_REQUIRE) {
2633             char* msg = SvPVx(ERRSV, n_a);
2634             DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
2635         } else if (startop) {
2636             char* msg = SvPVx(ERRSV, n_a);
2637
2638             POPBLOCK(cx,PL_curpm);
2639             POPEVAL(cx);
2640             Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2641         }
2642         SvREFCNT_dec(PL_rs);
2643         PL_rs = SvREFCNT_inc(PL_nrs);
2644 #ifdef USE_THREADS
2645         MUTEX_LOCK(&PL_eval_mutex);
2646         PL_eval_owner = 0;
2647         COND_SIGNAL(&PL_eval_cond);
2648         MUTEX_UNLOCK(&PL_eval_mutex);
2649 #endif /* USE_THREADS */
2650         RETPUSHUNDEF;
2651     }
2652     SvREFCNT_dec(PL_rs);
2653     PL_rs = SvREFCNT_inc(PL_nrs);
2654     PL_compiling.cop_line = 0;
2655     if (startop) {
2656         *startop = PL_eval_root;
2657         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2658         CvOUTSIDE(PL_compcv) = Nullcv;
2659     } else
2660         SAVEFREEOP(PL_eval_root);
2661     if (gimme & G_VOID)
2662         scalarvoid(PL_eval_root);
2663     else if (gimme & G_ARRAY)
2664         list(PL_eval_root);
2665     else
2666         scalar(PL_eval_root);
2667
2668     DEBUG_x(dump_eval());
2669
2670     /* Register with debugger: */
2671     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2672         CV *cv = get_cv("DB::postponed", FALSE);
2673         if (cv) {
2674             dSP;
2675             PUSHMARK(SP);
2676             XPUSHs((SV*)PL_compiling.cop_filegv);
2677             PUTBACK;
2678             call_sv((SV*)cv, G_DISCARD);
2679         }
2680     }
2681
2682     /* compiled okay, so do it */
2683
2684     CvDEPTH(PL_compcv) = 1;
2685     SP = PL_stack_base + POPMARK;               /* pop original mark */
2686     PL_op = saveop;                     /* The caller may need it. */
2687 #ifdef USE_THREADS
2688     MUTEX_LOCK(&PL_eval_mutex);
2689     PL_eval_owner = 0;
2690     COND_SIGNAL(&PL_eval_cond);
2691     MUTEX_UNLOCK(&PL_eval_mutex);
2692 #endif /* USE_THREADS */
2693
2694     RETURNOP(PL_eval_start);
2695 }
2696
2697 STATIC PerlIO *
2698 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2699 {
2700     STRLEN namelen = strlen(name);
2701     PerlIO *fp;
2702
2703     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2704         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2705         char *pmc = SvPV_nolen(pmcsv);
2706         Stat_t pmstat;
2707         Stat_t pmcstat;
2708         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2709             fp = PerlIO_open(name, mode);
2710         }
2711         else {
2712             if (PerlLIO_stat(name, &pmstat) < 0 ||
2713                 pmstat.st_mtime < pmcstat.st_mtime)
2714             {
2715                 fp = PerlIO_open(pmc, mode);
2716             }
2717             else {
2718                 fp = PerlIO_open(name, mode);
2719             }
2720         }
2721         SvREFCNT_dec(pmcsv);
2722     }
2723     else {
2724         fp = PerlIO_open(name, mode);
2725     }
2726     return fp;
2727 }
2728
2729 PP(pp_require)
2730 {
2731     djSP;
2732     register PERL_CONTEXT *cx;
2733     SV *sv;
2734     char *name;
2735     STRLEN len;
2736     char *tryname;
2737     SV *namesv = Nullsv;
2738     SV** svp;
2739     I32 gimme = G_SCALAR;
2740     PerlIO *tryrsfp = 0;
2741     STRLEN n_a;
2742
2743     sv = POPs;
2744     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2745         if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2746             DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2747                 SvPV(sv,n_a),PL_patchlevel);
2748         RETPUSHYES;
2749     }
2750     name = SvPV(sv, len);
2751     if (!(name && len > 0 && *name))
2752         DIE(aTHX_ "Null filename used");
2753     TAINT_PROPER("require");
2754     if (PL_op->op_type == OP_REQUIRE &&
2755       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2756       *svp != &PL_sv_undef)
2757         RETPUSHYES;
2758
2759     /* prepare to compile file */
2760
2761     if (*name == '/' ||
2762         (*name == '.' &&
2763             (name[1] == '/' ||
2764              (name[1] == '.' && name[2] == '/')))
2765 #ifdef DOSISH
2766       || (name[0] && name[1] == ':')
2767 #endif
2768 #ifdef WIN32
2769       || (name[0] == '\\' && name[1] == '\\')   /* UNC path */
2770 #endif
2771 #ifdef VMS
2772         || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
2773             (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2774 #endif
2775     )
2776     {
2777         tryname = name;
2778         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2779     }
2780     else {
2781         AV *ar = GvAVn(PL_incgv);
2782         I32 i;
2783 #ifdef VMS
2784         char *unixname;
2785         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2786 #endif
2787         {
2788             namesv = NEWSV(806, 0);
2789             for (i = 0; i <= AvFILL(ar); i++) {
2790                 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2791 #ifdef VMS
2792                 char *unixdir;
2793                 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2794                     continue;
2795                 sv_setpv(namesv, unixdir);
2796                 sv_catpv(namesv, unixname);
2797 #else
2798                 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
2799 #endif
2800                 TAINT_PROPER("require");
2801                 tryname = SvPVX(namesv);
2802                 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2803                 if (tryrsfp) {
2804                     if (tryname[0] == '.' && tryname[1] == '/')
2805                         tryname += 2;
2806                     break;
2807                 }
2808             }
2809         }
2810     }
2811     SAVESPTR(PL_compiling.cop_filegv);
2812     PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2813     SvREFCNT_dec(namesv);
2814     if (!tryrsfp) {
2815         if (PL_op->op_type == OP_REQUIRE) {
2816             char *msgstr = name;
2817             if (namesv) {                       /* did we lookup @INC? */
2818                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2819                 SV *dirmsgsv = NEWSV(0, 0);
2820                 AV *ar = GvAVn(PL_incgv);
2821                 I32 i;
2822                 sv_catpvn(msg, " in @INC", 8);
2823                 if (instr(SvPVX(msg), ".h "))
2824                     sv_catpv(msg, " (change .h to .ph maybe?)");
2825                 if (instr(SvPVX(msg), ".ph "))
2826                     sv_catpv(msg, " (did you run h2ph?)");
2827                 sv_catpv(msg, " (@INC contains:");
2828                 for (i = 0; i <= AvFILL(ar); i++) {
2829                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2830                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
2831                     sv_catsv(msg, dirmsgsv);
2832                 }
2833                 sv_catpvn(msg, ")", 1);
2834                 SvREFCNT_dec(dirmsgsv);
2835                 msgstr = SvPV_nolen(msg);
2836             }
2837             DIE(aTHX_ "Can't locate %s", msgstr);
2838         }
2839
2840         RETPUSHUNDEF;
2841     }
2842     else
2843         SETERRNO(0, SS$_NORMAL);
2844
2845     /* Assume success here to prevent recursive requirement. */
2846     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2847         newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2848
2849     ENTER;
2850     SAVETMPS;
2851     lex_start(sv_2mortal(newSVpvn("",0)));
2852     SAVEGENERICSV(PL_rsfp_filters);
2853     PL_rsfp_filters = Nullav;
2854
2855     PL_rsfp = tryrsfp;
2856     name = savepv(name);
2857     SAVEFREEPV(name);
2858     SAVEHINTS();
2859     PL_hints = 0;
2860     SAVEPPTR(PL_compiling.cop_warnings);
2861     if (PL_dowarn & G_WARN_ALL_ON)
2862         PL_compiling.cop_warnings = WARN_ALL ;
2863     else if (PL_dowarn & G_WARN_ALL_OFF)
2864         PL_compiling.cop_warnings = WARN_NONE ;
2865     else
2866         PL_compiling.cop_warnings = WARN_STD ;
2867
2868     /* switch to eval mode */
2869
2870     push_return(PL_op->op_next);
2871     PUSHBLOCK(cx, CXt_EVAL, SP);
2872     PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2873
2874     SAVEI16(PL_compiling.cop_line);
2875     PL_compiling.cop_line = 0;
2876
2877     PUTBACK;
2878 #ifdef USE_THREADS
2879     MUTEX_LOCK(&PL_eval_mutex);
2880     if (PL_eval_owner && PL_eval_owner != thr)
2881         while (PL_eval_owner)
2882             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2883     PL_eval_owner = thr;
2884     MUTEX_UNLOCK(&PL_eval_mutex);
2885 #endif /* USE_THREADS */
2886     return DOCATCH(doeval(G_SCALAR, NULL));
2887 }
2888
2889 PP(pp_dofile)
2890 {
2891     return pp_require();
2892 }
2893
2894 PP(pp_entereval)
2895 {
2896     djSP;
2897     register PERL_CONTEXT *cx;
2898     dPOPss;
2899     I32 gimme = GIMME_V, was = PL_sub_generation;
2900     char tmpbuf[TYPE_DIGITS(long) + 12];
2901     char *safestr;
2902     STRLEN len;
2903     OP *ret;
2904
2905     if (!SvPV(sv,len) || !len)
2906         RETPUSHUNDEF;
2907     TAINT_PROPER("eval");
2908
2909     ENTER;
2910     lex_start(sv);
2911     SAVETMPS;
2912
2913     /* switch to eval mode */
2914
2915     SAVESPTR(PL_compiling.cop_filegv);
2916     sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2917     PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2918     PL_compiling.cop_line = 1;
2919     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2920        deleting the eval's FILEGV from the stash before gv_check() runs
2921        (i.e. before run-time proper). To work around the coredump that
2922        ensues, we always turn GvMULTI_on for any globals that were
2923        introduced within evals. See force_ident(). GSAR 96-10-12 */
2924     safestr = savepv(tmpbuf);
2925     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2926     SAVEHINTS();
2927     PL_hints = PL_op->op_targ;
2928     SAVEPPTR(PL_compiling.cop_warnings);
2929     if (!specialWARN(PL_compiling.cop_warnings)) {
2930         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2931         SAVEFREESV(PL_compiling.cop_warnings) ;
2932     }
2933
2934     push_return(PL_op->op_next);
2935     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
2936     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2937
2938     /* prepare to compile string */
2939
2940     if (PERLDB_LINE && PL_curstash != PL_debstash)
2941         save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
2942     PUTBACK;
2943 #ifdef USE_THREADS
2944     MUTEX_LOCK(&PL_eval_mutex);
2945     if (PL_eval_owner && PL_eval_owner != thr)
2946         while (PL_eval_owner)
2947             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2948     PL_eval_owner = thr;
2949     MUTEX_UNLOCK(&PL_eval_mutex);
2950 #endif /* USE_THREADS */
2951     ret = doeval(gimme, NULL);
2952     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
2953         && ret != PL_op->op_next) {     /* Successive compilation. */
2954         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2955     }
2956     return DOCATCH(ret);
2957 }
2958
2959 PP(pp_leaveeval)
2960 {
2961     djSP;
2962     register SV **mark;
2963     SV **newsp;
2964     PMOP *newpm;
2965     I32 gimme;
2966     register PERL_CONTEXT *cx;
2967     OP *retop;
2968     U8 save_flags = PL_op -> op_flags;
2969     I32 optype;
2970
2971     POPBLOCK(cx,newpm);
2972     POPEVAL(cx);
2973     retop = pop_return();
2974
2975     TAINT_NOT;
2976     if (gimme == G_VOID)
2977         MARK = newsp;
2978     else if (gimme == G_SCALAR) {
2979         MARK = newsp + 1;
2980         if (MARK <= SP) {
2981             if (SvFLAGS(TOPs) & SVs_TEMP)
2982                 *MARK = TOPs;
2983             else
2984                 *MARK = sv_mortalcopy(TOPs);
2985         }
2986         else {
2987             MEXTEND(mark,0);
2988             *MARK = &PL_sv_undef;
2989         }
2990     }
2991     else {
2992         /* in case LEAVE wipes old return values */
2993         for (mark = newsp + 1; mark <= SP; mark++) {
2994             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2995                 *mark = sv_mortalcopy(*mark);
2996                 TAINT_NOT;      /* Each item is independent */
2997             }
2998         }
2999     }
3000     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3001
3002     if (AvFILLp(PL_comppad_name) >= 0)
3003         free_closures();
3004
3005 #ifdef DEBUGGING
3006     assert(CvDEPTH(PL_compcv) == 1);
3007 #endif
3008     CvDEPTH(PL_compcv) = 0;
3009     lex_end();
3010
3011     if (optype == OP_REQUIRE &&
3012         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3013     {
3014         /* Unassume the success we assumed earlier. */
3015         char *name = cx->blk_eval.old_name;
3016         (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3017         retop = Perl_die(aTHX_ "%s did not return a true value", name);
3018         /* die_where() did LEAVE, or we won't be here */
3019     }
3020     else {
3021         LEAVE;
3022         if (!(save_flags & OPf_SPECIAL))
3023             sv_setpv(ERRSV,"");
3024     }
3025
3026     RETURNOP(retop);
3027 }
3028
3029 PP(pp_entertry)
3030 {
3031     djSP;
3032     register PERL_CONTEXT *cx;
3033     I32 gimme = GIMME_V;
3034
3035     ENTER;
3036     SAVETMPS;
3037
3038     push_return(cLOGOP->op_other->op_next);
3039     PUSHBLOCK(cx, CXt_EVAL, SP);
3040     PUSHEVAL(cx, 0, 0);
3041     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3042
3043     PL_in_eval = EVAL_INEVAL;
3044     sv_setpv(ERRSV,"");
3045     PUTBACK;
3046     return DOCATCH(PL_op->op_next);
3047 }
3048
3049 PP(pp_leavetry)
3050 {
3051     djSP;
3052     register SV **mark;
3053     SV **newsp;
3054     PMOP *newpm;
3055     I32 gimme;
3056     register PERL_CONTEXT *cx;
3057     I32 optype;
3058
3059     POPBLOCK(cx,newpm);
3060     POPEVAL(cx);
3061     pop_return();
3062
3063     TAINT_NOT;
3064     if (gimme == G_VOID)
3065         SP = newsp;
3066     else if (gimme == G_SCALAR) {
3067         MARK = newsp + 1;
3068         if (MARK <= SP) {
3069             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3070                 *MARK = TOPs;
3071             else
3072                 *MARK = sv_mortalcopy(TOPs);
3073         }
3074         else {
3075             MEXTEND(mark,0);
3076             *MARK = &PL_sv_undef;
3077         }
3078         SP = MARK;
3079     }
3080     else {
3081         /* in case LEAVE wipes old return values */
3082         for (mark = newsp + 1; mark <= SP; mark++) {
3083             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3084                 *mark = sv_mortalcopy(*mark);
3085                 TAINT_NOT;      /* Each item is independent */
3086             }
3087         }
3088     }
3089     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3090
3091     LEAVE;
3092     sv_setpv(ERRSV,"");
3093     RETURN;
3094 }
3095
3096 STATIC void
3097 S_doparseform(pTHX_ SV *sv)
3098 {
3099     STRLEN len;
3100     register char *s = SvPV_force(sv, len);
3101     register char *send = s + len;
3102     register char *base;
3103     register I32 skipspaces = 0;
3104     bool noblank;
3105     bool repeat;
3106     bool postspace = FALSE;
3107     U16 *fops;
3108     register U16 *fpc;
3109     U16 *linepc;
3110     register I32 arg;
3111     bool ischop;
3112
3113     if (len == 0)
3114         Perl_croak(aTHX_ "Null picture in formline");
3115
3116     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3117     fpc = fops;
3118
3119     if (s < send) {
3120         linepc = fpc;
3121         *fpc++ = FF_LINEMARK;
3122         noblank = repeat = FALSE;
3123         base = s;
3124     }
3125
3126     while (s <= send) {
3127         switch (*s++) {
3128         default:
3129             skipspaces = 0;
3130             continue;
3131
3132         case '~':
3133             if (*s == '~') {
3134                 repeat = TRUE;
3135                 *s = ' ';
3136             }
3137             noblank = TRUE;
3138             s[-1] = ' ';
3139             /* FALL THROUGH */
3140         case ' ': case '\t':
3141             skipspaces++;
3142             continue;
3143
3144         case '\n': case 0:
3145             arg = s - base;
3146             skipspaces++;
3147             arg -= skipspaces;
3148             if (arg) {
3149                 if (postspace)
3150                     *fpc++ = FF_SPACE;
3151                 *fpc++ = FF_LITERAL;
3152                 *fpc++ = arg;
3153             }
3154             postspace = FALSE;
3155             if (s <= send)
3156                 skipspaces--;
3157             if (skipspaces) {
3158                 *fpc++ = FF_SKIP;
3159                 *fpc++ = skipspaces;
3160             }
3161             skipspaces = 0;
3162             if (s <= send)
3163                 *fpc++ = FF_NEWLINE;
3164             if (noblank) {
3165                 *fpc++ = FF_BLANK;
3166                 if (repeat)
3167                     arg = fpc - linepc + 1;
3168                 else
3169                     arg = 0;
3170                 *fpc++ = arg;
3171             }
3172             if (s < send) {
3173                 linepc = fpc;
3174                 *fpc++ = FF_LINEMARK;
3175                 noblank = repeat = FALSE;
3176                 base = s;
3177             }
3178             else
3179                 s++;
3180             continue;
3181
3182         case '@':
3183         case '^':
3184             ischop = s[-1] == '^';
3185
3186             if (postspace) {
3187                 *fpc++ = FF_SPACE;
3188                 postspace = FALSE;
3189             }
3190             arg = (s - base) - 1;
3191             if (arg) {
3192                 *fpc++ = FF_LITERAL;
3193                 *fpc++ = arg;
3194             }
3195
3196             base = s - 1;
3197             *fpc++ = FF_FETCH;
3198             if (*s == '*') {
3199                 s++;
3200                 *fpc++ = 0;
3201                 *fpc++ = FF_LINEGLOB;
3202             }
3203             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3204                 arg = ischop ? 512 : 0;
3205                 base = s - 1;
3206                 while (*s == '#')
3207                     s++;
3208                 if (*s == '.') {
3209                     char *f;
3210                     s++;
3211                     f = s;
3212                     while (*s == '#')
3213                         s++;
3214                     arg |= 256 + (s - f);
3215                 }
3216                 *fpc++ = s - base;              /* fieldsize for FETCH */
3217                 *fpc++ = FF_DECIMAL;
3218                 *fpc++ = arg;
3219             }
3220             else {
3221                 I32 prespace = 0;
3222                 bool ismore = FALSE;
3223
3224                 if (*s == '>') {
3225                     while (*++s == '>') ;
3226                     prespace = FF_SPACE;
3227                 }
3228                 else if (*s == '|') {
3229                     while (*++s == '|') ;
3230                     prespace = FF_HALFSPACE;
3231                     postspace = TRUE;
3232                 }
3233                 else {
3234                     if (*s == '<')
3235                         while (*++s == '<') ;
3236                     postspace = TRUE;
3237                 }
3238                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3239                     s += 3;
3240                     ismore = TRUE;
3241                 }
3242                 *fpc++ = s - base;              /* fieldsize for FETCH */
3243
3244                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3245
3246                 if (prespace)
3247                     *fpc++ = prespace;
3248                 *fpc++ = FF_ITEM;
3249                 if (ismore)
3250                     *fpc++ = FF_MORE;
3251                 if (ischop)
3252                     *fpc++ = FF_CHOP;
3253             }
3254             base = s;
3255             skipspaces = 0;
3256             continue;
3257         }
3258     }
3259     *fpc++ = FF_END;
3260
3261     arg = fpc - fops;
3262     { /* need to jump to the next word */
3263         int z;
3264         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3265         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3266         s = SvPVX(sv) + SvCUR(sv) + z;
3267     }
3268     Copy(fops, s, arg, U16);
3269     Safefree(fops);
3270     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3271     SvCOMPILED_on(sv);
3272 }
3273
3274 /*
3275  * The rest of this file was derived from source code contributed
3276  * by Tom Horsley.
3277  *
3278  * NOTE: this code was derived from Tom Horsley's qsort replacement
3279  * and should not be confused with the original code.
3280  */
3281
3282 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3283
3284    Permission granted to distribute under the same terms as perl which are
3285    (briefly):
3286
3287     This program is free software; you can redistribute it and/or modify
3288     it under the terms of either:
3289
3290         a) the GNU General Public License as published by the Free
3291         Software Foundation; either version 1, or (at your option) any
3292         later version, or
3293
3294         b) the "Artistic License" which comes with this Kit.
3295
3296    Details on the perl license can be found in the perl source code which
3297    may be located via the www.perl.com web page.
3298
3299    This is the most wonderfulest possible qsort I can come up with (and
3300    still be mostly portable) My (limited) tests indicate it consistently
3301    does about 20% fewer calls to compare than does the qsort in the Visual
3302    C++ library, other vendors may vary.
3303
3304    Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3305    others I invented myself (or more likely re-invented since they seemed
3306    pretty obvious once I watched the algorithm operate for a while).
3307
3308    Most of this code was written while watching the Marlins sweep the Giants
3309    in the 1997 National League Playoffs - no Braves fans allowed to use this
3310    code (just kidding :-).
3311
3312    I realize that if I wanted to be true to the perl tradition, the only
3313    comment in this file would be something like:
3314
3315    ...they shuffled back towards the rear of the line. 'No, not at the
3316    rear!'  the slave-driver shouted. 'Three files up. And stay there...
3317
3318    However, I really needed to violate that tradition just so I could keep
3319    track of what happens myself, not to mention some poor fool trying to
3320    understand this years from now :-).
3321 */
3322
3323 /* ********************************************************** Configuration */
3324
3325 #ifndef QSORT_ORDER_GUESS
3326 #define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3327 #endif
3328
3329 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3330    future processing - a good max upper bound is log base 2 of memory size
3331    (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3332    safely be smaller than that since the program is taking up some space and
3333    most operating systems only let you grab some subset of contiguous
3334    memory (not to mention that you are normally sorting data larger than
3335    1 byte element size :-).
3336 */
3337 #ifndef QSORT_MAX_STACK
3338 #define QSORT_MAX_STACK 32
3339 #endif
3340
3341 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3342    Anything bigger and we use qsort. If you make this too small, the qsort
3343    will probably break (or become less efficient), because it doesn't expect
3344    the middle element of a partition to be the same as the right or left -
3345    you have been warned).
3346 */
3347 #ifndef QSORT_BREAK_EVEN
3348 #define QSORT_BREAK_EVEN 6
3349 #endif
3350
3351 /* ************************************************************* Data Types */
3352
3353 /* hold left and right index values of a partition waiting to be sorted (the
3354    partition includes both left and right - right is NOT one past the end or
3355    anything like that).
3356 */
3357 struct partition_stack_entry {
3358    int left;
3359    int right;
3360 #ifdef QSORT_ORDER_GUESS
3361    int qsort_break_even;
3362 #endif
3363 };
3364
3365 /* ******************************************************* Shorthand Macros */
3366
3367 /* Note that these macros will be used from inside the qsort function where
3368    we happen to know that the variable 'elt_size' contains the size of an
3369    array element and the variable 'temp' points to enough space to hold a
3370    temp element and the variable 'array' points to the array being sorted
3371    and 'compare' is the pointer to the compare routine.
3372
3373    Also note that there are very many highly architecture specific ways
3374    these might be sped up, but this is simply the most generally portable
3375    code I could think of.
3376 */
3377
3378 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3379 */
3380 #define qsort_cmp(elt1, elt2) \
3381    ((*compare)(aTHXo_ array[elt1], array[elt2]))
3382
3383 #ifdef QSORT_ORDER_GUESS
3384 #define QSORT_NOTICE_SWAP swapped++;
3385 #else
3386 #define QSORT_NOTICE_SWAP
3387 #endif
3388
3389 /* swaps contents of array elements elt1, elt2.
3390 */
3391 #define qsort_swap(elt1, elt2) \
3392    STMT_START { \
3393       QSORT_NOTICE_SWAP \
3394       temp = array[elt1]; \
3395       array[elt1] = array[elt2]; \
3396       array[elt2] = temp; \
3397    } STMT_END
3398
3399 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3400    elt3 and elt3 gets elt1.
3401 */
3402 #define qsort_rotate(elt1, elt2, elt3) \
3403    STMT_START { \
3404       QSORT_NOTICE_SWAP \
3405       temp = array[elt1]; \
3406       array[elt1] = array[elt2]; \
3407       array[elt2] = array[elt3]; \
3408       array[elt3] = temp; \
3409    } STMT_END
3410
3411 /* ************************************************************ Debug stuff */
3412
3413 #ifdef QSORT_DEBUG
3414
3415 static void
3416 break_here()
3417 {
3418    return; /* good place to set a breakpoint */
3419 }
3420
3421 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3422
3423 static void
3424 doqsort_all_asserts(
3425    void * array,
3426    size_t num_elts,
3427    size_t elt_size,
3428    int (*compare)(const void * elt1, const void * elt2),
3429    int pc_left, int pc_right, int u_left, int u_right)
3430 {
3431    int i;
3432
3433    qsort_assert(pc_left <= pc_right);
3434    qsort_assert(u_right < pc_left);
3435    qsort_assert(pc_right < u_left);
3436    for (i = u_right + 1; i < pc_left; ++i) {
3437       qsort_assert(qsort_cmp(i, pc_left) < 0);
3438    }
3439    for (i = pc_left; i < pc_right; ++i) {
3440       qsort_assert(qsort_cmp(i, pc_right) == 0);
3441    }
3442    for (i = pc_right + 1; i < u_left; ++i) {
3443       qsort_assert(qsort_cmp(pc_right, i) < 0);
3444    }
3445 }
3446
3447 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3448    doqsort_all_asserts(array, num_elts, elt_size, compare, \
3449                  PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3450
3451 #else
3452
3453 #define qsort_assert(t) ((void)0)
3454
3455 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3456
3457 #endif
3458
3459 /* ****************************************************************** qsort */
3460
3461 STATIC void
3462 S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3463 {
3464    register SV * temp;
3465
3466    struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3467    int next_stack_entry = 0;
3468
3469    int part_left;
3470    int part_right;
3471 #ifdef QSORT_ORDER_GUESS
3472    int qsort_break_even;
3473    int swapped;
3474 #endif
3475
3476    /* Make sure we actually have work to do.
3477    */
3478    if (num_elts <= 1) {
3479       return;
3480    }
3481
3482    /* Setup the initial partition definition and fall into the sorting loop
3483    */
3484    part_left = 0;
3485    part_right = (int)(num_elts - 1);
3486 #ifdef QSORT_ORDER_GUESS
3487    qsort_break_even = QSORT_BREAK_EVEN;
3488 #else
3489 #define qsort_break_even QSORT_BREAK_EVEN
3490 #endif
3491    for ( ; ; ) {
3492       if ((part_right - part_left) >= qsort_break_even) {
3493          /* OK, this is gonna get hairy, so lets try to document all the
3494             concepts and abbreviations and variables and what they keep
3495             track of:
3496
3497             pc: pivot chunk - the set of array elements we accumulate in the
3498                 middle of the partition, all equal in value to the original
3499                 pivot element selected. The pc is defined by:
3500
3501                 pc_left - the leftmost array index of the pc
3502                 pc_right - the rightmost array index of the pc
3503
3504                 we start with pc_left == pc_right and only one element
3505                 in the pivot chunk (but it can grow during the scan).
3506
3507             u:  uncompared elements - the set of elements in the partition
3508                 we have not yet compared to the pivot value. There are two
3509                 uncompared sets during the scan - one to the left of the pc
3510                 and one to the right.
3511
3512                 u_right - the rightmost index of the left side's uncompared set
3513                 u_left - the leftmost index of the right side's uncompared set
3514
3515                 The leftmost index of the left sides's uncompared set
3516                 doesn't need its own variable because it is always defined
3517                 by the leftmost edge of the whole partition (part_left). The
3518                 same goes for the rightmost edge of the right partition
3519                 (part_right).
3520
3521                 We know there are no uncompared elements on the left once we
3522                 get u_right < part_left and no uncompared elements on the
3523                 right once u_left > part_right. When both these conditions
3524                 are met, we have completed the scan of the partition.
3525
3526                 Any elements which are between the pivot chunk and the
3527                 uncompared elements should be less than the pivot value on
3528                 the left side and greater than the pivot value on the right
3529                 side (in fact, the goal of the whole algorithm is to arrange
3530                 for that to be true and make the groups of less-than and
3531                 greater-then elements into new partitions to sort again).
3532
3533             As you marvel at the complexity of the code and wonder why it
3534             has to be so confusing. Consider some of the things this level
3535             of confusion brings:
3536
3537             Once I do a compare, I squeeze every ounce of juice out of it. I
3538             never do compare calls I don't have to do, and I certainly never
3539             do redundant calls.
3540
3541             I also never swap any elements unless I can prove there is a
3542             good reason. Many sort algorithms will swap a known value with
3543             an uncompared value just to get things in the right place (or
3544             avoid complexity :-), but that uncompared value, once it gets
3545             compared, may then have to be swapped again. A lot of the
3546             complexity of this code is due to the fact that it never swaps
3547             anything except compared values, and it only swaps them when the
3548             compare shows they are out of position.
3549          */
3550          int pc_left, pc_right;
3551          int u_right, u_left;
3552
3553          int s;
3554
3555          pc_left = ((part_left + part_right) / 2);
3556          pc_right = pc_left;
3557          u_right = pc_left - 1;
3558          u_left = pc_right + 1;
3559
3560          /* Qsort works best when the pivot value is also the median value
3561             in the partition (unfortunately you can't find the median value
3562             without first sorting :-), so to give the algorithm a helping
3563             hand, we pick 3 elements and sort them and use the median value
3564             of that tiny set as the pivot value.
3565
3566             Some versions of qsort like to use the left middle and right as
3567             the 3 elements to sort so they can insure the ends of the
3568             partition will contain values which will stop the scan in the
3569             compare loop, but when you have to call an arbitrarily complex
3570             routine to do a compare, its really better to just keep track of
3571             array index values to know when you hit the edge of the
3572             partition and avoid the extra compare. An even better reason to
3573             avoid using a compare call is the fact that you can drop off the
3574             edge of the array if someone foolishly provides you with an
3575             unstable compare function that doesn't always provide consistent
3576             results.
3577
3578             So, since it is simpler for us to compare the three adjacent
3579             elements in the middle of the partition, those are the ones we
3580             pick here (conveniently pointed at by u_right, pc_left, and
3581             u_left). The values of the left, center, and right elements
3582             are refered to as l c and r in the following comments.
3583          */
3584
3585 #ifdef QSORT_ORDER_GUESS
3586          swapped = 0;
3587 #endif
3588          s = qsort_cmp(u_right, pc_left);
3589          if (s < 0) {
3590             /* l < c */
3591             s = qsort_cmp(pc_left, u_left);
3592             /* if l < c, c < r - already in order - nothing to do */
3593             if (s == 0) {
3594                /* l < c, c == r - already in order, pc grows */
3595                ++pc_right;
3596                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3597             } else if (s > 0) {
3598                /* l < c, c > r - need to know more */
3599                s = qsort_cmp(u_right, u_left);
3600                if (s < 0) {
3601                   /* l < c, c > r, l < r - swap c & r to get ordered */
3602                   qsort_swap(pc_left, u_left);
3603                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3604                } else if (s == 0) {
3605                   /* l < c, c > r, l == r - swap c&r, grow pc */
3606                   qsort_swap(pc_left, u_left);
3607                   --pc_left;
3608                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3609                } else {
3610                   /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3611                   qsort_rotate(pc_left, u_right, u_left);
3612                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3613                }
3614             }
3615          } else if (s == 0) {
3616             /* l == c */
3617             s = qsort_cmp(pc_left, u_left);
3618             if (s < 0) {
3619                /* l == c, c < r - already in order, grow pc */
3620                --pc_left;
3621                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3622             } else if (s == 0) {
3623                /* l == c, c == r - already in order, grow pc both ways */
3624                --pc_left;
3625                ++pc_right;
3626                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3627             } else {
3628                /* l == c, c > r - swap l & r, grow pc */
3629                qsort_swap(u_right, u_left);
3630                ++pc_right;
3631                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3632             }
3633          } else {
3634             /* l > c */
3635             s = qsort_cmp(pc_left, u_left);
3636             if (s < 0) {
3637                /* l > c, c < r - need to know more */
3638                s = qsort_cmp(u_right, u_left);
3639                if (s < 0) {
3640                   /* l > c, c < r, l < r - swap l & c to get ordered */
3641                   qsort_swap(u_right, pc_left);
3642                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3643                } else if (s == 0) {
3644                   /* l > c, c < r, l == r - swap l & c, grow pc */
3645                   qsort_swap(u_right, pc_left);
3646                   ++pc_right;
3647                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3648                } else {
3649                   /* l > c, c < r, l > r - rotate lcr into crl to order */
3650                   qsort_rotate(u_right, pc_left, u_left);
3651                   qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3652                }
3653             } else if (s == 0) {
3654                /* l > c, c == r - swap ends, grow pc */
3655                qsort_swap(u_right, u_left);
3656                --pc_left;
3657                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3658             } else {
3659                /* l > c, c > r - swap ends to get in order */
3660                qsort_swap(u_right, u_left);
3661                qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3662             }
3663          }
3664          /* We now know the 3 middle elements have been compared and
3665             arranged in the desired order, so we can shrink the uncompared
3666             sets on both sides
3667          */
3668          --u_right;
3669          ++u_left;
3670          qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3671
3672          /* The above massive nested if was the simple part :-). We now have
3673             the middle 3 elements ordered and we need to scan through the
3674             uncompared sets on either side, swapping elements that are on
3675             the wrong side or simply shuffling equal elements around to get
3676             all equal elements into the pivot chunk.
3677          */
3678
3679          for ( ; ; ) {
3680             int still_work_on_left;
3681             int still_work_on_right;
3682
3683             /* Scan the uncompared values on the left. If I find a value
3684                equal to the pivot value, move it over so it is adjacent to
3685                the pivot chunk and expand the pivot chunk. If I find a value
3686                less than the pivot value, then just leave it - its already
3687                on the correct side of the partition. If I find a greater
3688                value, then stop the scan.
3689             */
3690             while (still_work_on_left = (u_right >= part_left)) {
3691                s = qsort_cmp(u_right, pc_left);
3692                if (s < 0) {
3693                   --u_right;
3694                } else if (s == 0) {
3695                   --pc_left;
3696                   if (pc_left != u_right) {
3697                      qsort_swap(u_right, pc_left);
3698                   }
3699                   --u_right;
3700                } else {
3701                   break;
3702                }
3703                qsort_assert(u_right < pc_left);
3704                qsort_assert(pc_left <= pc_right);
3705                qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3706                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3707             }
3708
3709             /* Do a mirror image scan of uncompared values on the right
3710             */
3711             while (still_work_on_right = (u_left <= part_right)) {
3712                s = qsort_cmp(pc_right, u_left);
3713                if (s < 0) {
3714                   ++u_left;
3715                } else if (s == 0) {
3716                   ++pc_right;
3717                   if (pc_right != u_left) {
3718                      qsort_swap(pc_right, u_left);
3719                   }
3720                   ++u_left;
3721                } else {
3722                   break;
3723                }
3724                qsort_assert(u_left > pc_right);
3725                qsort_assert(pc_left <= pc_right);
3726                qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3727                qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3728             }
3729
3730             if (still_work_on_left) {
3731                /* I know I have a value on the left side which needs to be
3732                   on the right side, but I need to know more to decide
3733                   exactly the best thing to do with it.
3734                */
3735                if (still_work_on_right) {
3736                   /* I know I have values on both side which are out of
3737                      position. This is a big win because I kill two birds
3738                      with one swap (so to speak). I can advance the
3739                      uncompared pointers on both sides after swapping both
3740                      of them into the right place.
3741                   */
3742                   qsort_swap(u_right, u_left);
3743                   --u_right;
3744                   ++u_left;
3745                   qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3746                } else {
3747                   /* I have an out of position value on the left, but the
3748                      right is fully scanned, so I "slide" the pivot chunk
3749                      and any less-than values left one to make room for the
3750                      greater value over on the right. If the out of position
3751                      value is immediately adjacent to the pivot chunk (there
3752                      are no less-than values), I can do that with a swap,
3753                      otherwise, I have to rotate one of the less than values
3754                      into the former position of the out of position value
3755                      and the right end of the pivot chunk into the left end
3756                      (got all that?).
3757                   */
3758                   --pc_left;
3759                   if (pc_left == u_right) {
3760                      qsort_swap(u_right, pc_right);
3761                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3762                   } else {
3763                      qsort_rotate(u_right, pc_left, pc_right);
3764                      qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3765                   }
3766                   --pc_right;
3767                   --u_right;
3768                }
3769             } else if (still_work_on_right) {
3770                /* Mirror image of complex case above: I have an out of
3771                   position value on the right, but the left is fully
3772                   scanned, so I need to shuffle things around to make room
3773                   for the right value on the left.
3774                */
3775                ++pc_right;
3776                if (pc_right == u_left) {
3777                   qsort_swap(u_left, pc_left);
3778                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3779                } else {
3780                   qsort_rotate(pc_right, pc_left, u_left);
3781                   qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3782                }
3783                ++pc_left;
3784                ++u_left;
3785             } else {
3786                /* No more scanning required on either side of partition,
3787                   break out of loop and figure out next set of partitions
3788                */
3789                break;
3790             }
3791          }
3792
3793          /* The elements in the pivot chunk are now in the right place. They
3794             will never move or be compared again. All I have to do is decide
3795             what to do with the stuff to the left and right of the pivot
3796             chunk.
3797
3798             Notes on the QSORT_ORDER_GUESS ifdef code:
3799
3800             1. If I just built these partitions without swapping any (or
3801                very many) elements, there is a chance that the elements are
3802                already ordered properly (being properly ordered will
3803                certainly result in no swapping, but the converse can't be
3804                proved :-).
3805
3806             2. A (properly written) insertion sort will run faster on
3807                already ordered data than qsort will.
3808
3809             3. Perhaps there is some way to make a good guess about
3810                switching to an insertion sort earlier than partition size 6
3811                (for instance - we could save the partition size on the stack
3812                and increase the size each time we find we didn't swap, thus
3813                switching to insertion sort earlier for partitions with a
3814                history of not swapping).
3815
3816             4. Naturally, if I just switch right away, it will make
3817                artificial benchmarks with pure ascending (or descending)
3818                data look really good, but is that a good reason in general?
3819                Hard to say...
3820          */
3821
3822 #ifdef QSORT_ORDER_GUESS
3823          if (swapped < 3) {
3824 #if QSORT_ORDER_GUESS == 1
3825             qsort_break_even = (part_right - part_left) + 1;
3826 #endif
3827 #if QSORT_ORDER_GUESS == 2
3828             qsort_break_even *= 2;
3829 #endif
3830 #if QSORT_ORDER_GUESS == 3
3831             int prev_break = qsort_break_even;
3832             qsort_break_even *= qsort_break_even;
3833             if (qsort_break_even < prev_break) {
3834                qsort_break_even = (part_right - part_left) + 1;
3835             }
3836 #endif
3837          } else {
3838             qsort_break_even = QSORT_BREAK_EVEN;
3839          }
3840 #endif
3841
3842          if (part_left < pc_left) {
3843             /* There are elements on the left which need more processing.
3844                Check the right as well before deciding what to do.
3845             */
3846             if (pc_right < part_right) {
3847                /* We have two partitions to be sorted. Stack the biggest one
3848                   and process the smallest one on the next iteration. This
3849                   minimizes the stack height by insuring that any additional
3850                   stack entries must come from the smallest partition which
3851                   (because it is smallest) will have the fewest
3852                   opportunities to generate additional stack entries.
3853                */
3854                if ((part_right - pc_right) > (pc_left - part_left)) {
3855                   /* stack the right partition, process the left */
3856                   partition_stack[next_stack_entry].left = pc_right + 1;
3857                   partition_stack[next_stack_entry].right = part_right;
3858 #ifdef QSORT_ORDER_GUESS
3859                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3860 #endif
3861                   part_right = pc_left - 1;
3862                } else {
3863                   /* stack the left partition, process the right */
3864                   partition_stack[next_stack_entry].left = part_left;
3865                   partition_stack[next_stack_entry].right = pc_left - 1;
3866 #ifdef QSORT_ORDER_GUESS
3867                   partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3868 #endif
3869                   part_left = pc_right + 1;
3870                }
3871                qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3872                ++next_stack_entry;
3873             } else {
3874                /* The elements on the left are the only remaining elements
3875                   that need sorting, arrange for them to be processed as the
3876                   next partition.
3877                */
3878                part_right = pc_left - 1;
3879             }
3880          } else if (pc_right < part_right) {
3881             /* There is only one chunk on the right to be sorted, make it
3882                the new partition and loop back around.
3883             */
3884             part_left = pc_right + 1;
3885          } else {
3886             /* This whole partition wound up in the pivot chunk, so
3887                we need to get a new partition off the stack.
3888             */
3889             if (next_stack_entry == 0) {
3890                /* the stack is empty - we are done */
3891                break;
3892             }
3893             --next_stack_entry;
3894             part_left = partition_stack[next_stack_entry].left;
3895             part_right = partition_stack[next_stack_entry].right;
3896 #ifdef QSORT_ORDER_GUESS
3897             qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3898 #endif
3899          }
3900       } else {
3901          /* This partition is too small to fool with qsort complexity, just
3902             do an ordinary insertion sort to minimize overhead.
3903          */
3904          int i;
3905          /* Assume 1st element is in right place already, and start checking
3906             at 2nd element to see where it should be inserted.
3907          */
3908          for (i = part_left + 1; i <= part_right; ++i) {
3909             int j;
3910             /* Scan (backwards - just in case 'i' is already in right place)
3911                through the elements already sorted to see if the ith element
3912                belongs ahead of one of them.
3913             */
3914             for (j = i - 1; j >= part_left; --j) {
3915                if (qsort_cmp(i, j) >= 0) {
3916                   /* i belongs right after j
3917                   */
3918                   break;
3919                }
3920             }
3921             ++j;
3922             if (j != i) {
3923                /* Looks like we really need to move some things
3924                */
3925                int k;
3926                temp = array[i];
3927                for (k = i - 1; k >= j; --k)
3928                   array[k + 1] = array[k];
3929                array[j] = temp;
3930             }
3931          }
3932
3933          /* That partition is now sorted, grab the next one, or get out
3934             of the loop if there aren't any more.
3935          */
3936
3937          if (next_stack_entry == 0) {
3938             /* the stack is empty - we are done */
3939             break;
3940          }
3941          --next_stack_entry;
3942          part_left = partition_stack[next_stack_entry].left;
3943          part_right = partition_stack[next_stack_entry].right;
3944 #ifdef QSORT_ORDER_GUESS
3945          qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3946 #endif
3947       }
3948    }
3949
3950    /* Believe it or not, the array is sorted at this point! */
3951 }
3952
3953
3954 #ifdef PERL_OBJECT
3955 #define NO_XSLOCKS
3956 #undef this
3957 #define this pPerl
3958 #include "XSUB.h"
3959 #endif
3960
3961
3962 static I32
3963 sortcv(pTHXo_ SV *a, SV *b)
3964 {
3965     dTHR;
3966     I32 oldsaveix = PL_savestack_ix;
3967     I32 oldscopeix = PL_scopestack_ix;
3968     I32 result;
3969     GvSV(PL_firstgv) = a;
3970     GvSV(PL_secondgv) = b;
3971     PL_stack_sp = PL_stack_base;
3972     PL_op = PL_sortcop;
3973     CALLRUNOPS(aTHX);
3974     if (PL_stack_sp != PL_stack_base + 1)
3975         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
3976     if (!SvNIOKp(*PL_stack_sp))
3977         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
3978     result = SvIV(*PL_stack_sp);
3979     while (PL_scopestack_ix > oldscopeix) {
3980         LEAVE;
3981     }
3982     leave_scope(oldsaveix);
3983     return result;
3984 }
3985
3986
3987 static I32
3988 sv_ncmp(pTHXo_ SV *a, SV *b)
3989 {
3990     NV nv1 = SvNV(a);
3991     NV nv2 = SvNV(b);
3992     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
3993 }
3994
3995 static I32
3996 sv_i_ncmp(pTHXo_ SV *a, SV *b)
3997 {
3998     IV iv1 = SvIV(a);
3999     IV iv2 = SvIV(b);
4000     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4001 }
4002 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4003           *svp = Nullsv;                                \
4004           if (PL_amagic_generation) { \
4005             if (SvAMAGIC(left)||SvAMAGIC(right))\
4006                 *svp = amagic_call(left, \
4007                                    right, \
4008                                    CAT2(meth,_amg), \
4009                                    0); \
4010           } \
4011         } STMT_END
4012
4013 static I32
4014 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4015 {
4016     SV *tmpsv;
4017     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4018     if (tmpsv) {
4019         NV d;
4020
4021         if (SvIOK(tmpsv)) {
4022             I32 i = SvIVX(tmpsv);
4023             if (i > 0)
4024                return 1;
4025             return i? -1 : 0;
4026         }
4027         d = SvNV(tmpsv);
4028         if (d > 0)
4029            return 1;
4030         return d? -1 : 0;
4031      }
4032      return sv_ncmp(aTHXo_ a, b);
4033 }
4034
4035 static I32
4036 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4037 {
4038     SV *tmpsv;
4039     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4040     if (tmpsv) {
4041         NV d;
4042
4043         if (SvIOK(tmpsv)) {
4044             I32 i = SvIVX(tmpsv);
4045             if (i > 0)
4046                return 1;
4047             return i? -1 : 0;
4048         }
4049         d = SvNV(tmpsv);
4050         if (d > 0)
4051            return 1;
4052         return d? -1 : 0;
4053     }
4054     return sv_i_ncmp(aTHXo_ a, b);
4055 }
4056
4057 static I32
4058 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4059 {
4060     SV *tmpsv;
4061     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4062     if (tmpsv) {
4063         NV d;
4064
4065         if (SvIOK(tmpsv)) {
4066             I32 i = SvIVX(tmpsv);
4067             if (i > 0)
4068                return 1;
4069             return i? -1 : 0;
4070         }
4071         d = SvNV(tmpsv);
4072         if (d > 0)
4073            return 1;
4074         return d? -1 : 0;
4075     }
4076     return sv_cmp(str1, str2);
4077 }
4078
4079 static I32
4080 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4081 {
4082     SV *tmpsv;
4083     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4084     if (tmpsv) {
4085         NV d;
4086
4087         if (SvIOK(tmpsv)) {
4088             I32 i = SvIVX(tmpsv);
4089             if (i > 0)
4090                return 1;
4091             return i? -1 : 0;
4092         }
4093         d = SvNV(tmpsv);
4094         if (d > 0)
4095            return 1;
4096         return d? -1 : 0;
4097     }
4098     return sv_cmp_locale(str1, str2);
4099 }
4100
4101 #ifdef PERL_OBJECT
4102
4103 static I32
4104 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4105 {
4106     return sv_cmp_locale(str1, str2);
4107 }
4108
4109 static I32
4110 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4111 {
4112     return sv_cmp(str1, str2);
4113 }
4114
4115 #endif /* PERL_OBJECT */