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