pp_ctl.c

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