pp_ctl.c

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