pp_ctl.c

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