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