pp_ctl.c

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