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