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