pp_ctl.c

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