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