pp_ctl.c

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