pp_ctl.c

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