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