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     SV *encoding;
3040     OP *op;
3041
3042     sv = POPs;
3043     if (SvNIOKp(sv)) {
3044         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
3045             UV rev = 0, ver = 0, sver = 0;
3046             STRLEN len;
3047             U8 *s = (U8*)SvPVX(sv);
3048             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3049             if (s < end) {
3050                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3051                 s += len;
3052                 if (s < end) {
3053                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3054                     s += len;
3055                     if (s < end)
3056                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3057                 }
3058             }
3059             if (PERL_REVISION < rev
3060                 || (PERL_REVISION == rev
3061                     && (PERL_VERSION < ver
3062                         || (PERL_VERSION == ver
3063                             && PERL_SUBVERSION < sver))))
3064             {
3065                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3066                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3067                     PERL_VERSION, PERL_SUBVERSION);
3068             }
3069             if (ckWARN(WARN_PORTABLE))
3070                 Perl_warner(aTHX_ WARN_PORTABLE,
3071                         "v-string in use/require non-portable");
3072             RETPUSHYES;
3073         }
3074         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3075             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3076                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3077                 + 0.00000099 < SvNV(sv))
3078             {
3079                 NV nrev = SvNV(sv);
3080                 UV rev = (UV)nrev;
3081                 NV nver = (nrev - rev) * 1000;
3082                 UV ver = (UV)(nver + 0.0009);
3083                 NV nsver = (nver - ver) * 1000;
3084                 UV sver = (UV)(nsver + 0.0009);
3085
3086                 /* help out with the "use 5.6" confusion */
3087                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3088                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3089                         "this is only v%d.%d.%d, stopped"
3090                         " (did you mean v%"UVuf".%03"UVuf"?)",
3091                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3092                         PERL_SUBVERSION, rev, ver/100);
3093                 }
3094                 else {
3095                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3096                         "this is only v%d.%d.%d, stopped",
3097                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3098                         PERL_SUBVERSION);
3099                 }
3100             }
3101             RETPUSHYES;
3102         }
3103     }
3104     name = SvPV(sv, len);
3105     if (!(name && len > 0 && *name))
3106         DIE(aTHX_ "Null filename used");
3107     TAINT_PROPER("require");
3108     if (PL_op->op_type == OP_REQUIRE &&
3109       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3110       *svp != &PL_sv_undef)
3111         RETPUSHYES;
3112
3113     /* prepare to compile file */
3114
3115 #ifdef MACOS_TRADITIONAL
3116     if (PERL_FILE_IS_ABSOLUTE(name)
3117         || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3118     {
3119         tryname = name;
3120         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3121         /* We consider paths of the form :a:b ambiguous and interpret them first
3122            as global then as local
3123         */
3124         if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3125             goto trylocal;
3126     }
3127     else
3128 trylocal: {
3129 #else
3130     if (PERL_FILE_IS_ABSOLUTE(name)
3131         || (*name == '.' && (name[1] == '/' ||
3132                              (name[1] == '.' && name[2] == '/'))))
3133     {
3134         tryname = name;
3135         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3136     }
3137     else {
3138 #endif
3139         AV *ar = GvAVn(PL_incgv);
3140         I32 i;
3141 #ifdef VMS
3142         char *unixname;
3143         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3144 #endif
3145         {
3146             namesv = NEWSV(806, 0);
3147             for (i = 0; i <= AvFILL(ar); i++) {
3148                 SV *dirsv = *av_fetch(ar, i, TRUE);
3149
3150                 if (SvROK(dirsv)) {
3151                     int count;
3152                     SV *loader = dirsv;
3153
3154                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3155                         && !sv_isobject(loader))
3156                     {
3157                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3158                     }
3159
3160                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3161                                    PTR2UV(SvRV(dirsv)), name);
3162                     tryname = SvPVX(namesv);
3163                     tryrsfp = 0;
3164
3165                     ENTER;
3166                     SAVETMPS;
3167                     EXTEND(SP, 2);
3168
3169                     PUSHMARK(SP);
3170                     PUSHs(dirsv);
3171                     PUSHs(sv);
3172                     PUTBACK;
3173                     if (sv_isobject(loader))
3174                         count = call_method("INC", G_ARRAY);
3175                     else
3176                         count = call_sv(loader, G_ARRAY);
3177                     SPAGAIN;
3178
3179                     if (count > 0) {
3180                         int i = 0;
3181                         SV *arg;
3182
3183                         SP -= count - 1;
3184                         arg = SP[i++];
3185
3186                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3187                             arg = SvRV(arg);
3188                         }
3189
3190                         if (SvTYPE(arg) == SVt_PVGV) {
3191                             IO *io = GvIO((GV *)arg);
3192
3193                             ++filter_has_file;
3194
3195                             if (io) {
3196                                 tryrsfp = IoIFP(io);
3197                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3198                                     /* reading from a child process doesn't
3199                                        nest -- when returning from reading
3200                                        the inner module, the outer one is
3201                                        unreadable (closed?)  I've tried to
3202                                        save the gv to manage the lifespan of
3203                                        the pipe, but this didn't help. XXX */
3204                                     filter_child_proc = (GV *)arg;
3205                                     (void)SvREFCNT_inc(filter_child_proc);
3206                                 }
3207                                 else {
3208                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3209                                         PerlIO_close(IoOFP(io));
3210                                     }
3211                                     IoIFP(io) = Nullfp;
3212                                     IoOFP(io) = Nullfp;
3213                                 }
3214                             }
3215
3216                             if (i < count) {
3217                                 arg = SP[i++];
3218                             }
3219                         }
3220
3221                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3222                             filter_sub = arg;
3223                             (void)SvREFCNT_inc(filter_sub);
3224
3225                             if (i < count) {
3226                                 filter_state = SP[i];
3227                                 (void)SvREFCNT_inc(filter_state);
3228                             }
3229
3230                             if (tryrsfp == 0) {
3231                                 tryrsfp = PerlIO_open("/dev/null",
3232                                                       PERL_SCRIPT_MODE);
3233                             }
3234                         }
3235                     }
3236
3237                     PUTBACK;
3238                     FREETMPS;
3239                     LEAVE;
3240
3241                     if (tryrsfp) {
3242                         hook_sv = dirsv;
3243                         break;
3244                     }
3245
3246                     filter_has_file = 0;
3247                     if (filter_child_proc) {
3248                         SvREFCNT_dec(filter_child_proc);
3249                         filter_child_proc = 0;
3250                     }
3251                     if (filter_state) {
3252                         SvREFCNT_dec(filter_state);
3253                         filter_state = 0;
3254                     }
3255                     if (filter_sub) {
3256                         SvREFCNT_dec(filter_sub);
3257                         filter_sub = 0;
3258                     }
3259                 }
3260                 else {
3261                     char *dir = SvPVx(dirsv, n_a);
3262 #ifdef MACOS_TRADITIONAL
3263                     char buf[256];
3264                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3265 #else
3266 #ifdef VMS
3267                     char *unixdir;
3268                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3269                         continue;
3270                     sv_setpv(namesv, unixdir);
3271                     sv_catpv(namesv, unixname);
3272 #else
3273                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3274 #endif
3275 #endif
3276                     TAINT_PROPER("require");
3277                     tryname = SvPVX(namesv);
3278 #ifdef MACOS_TRADITIONAL
3279                     {
3280                         /* Convert slashes in the name part, but not the directory part, to colons */
3281                         char * colon;
3282                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3283                             *colon++ = ':';
3284                     }
3285 #endif
3286                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3287                     if (tryrsfp) {
3288                         if (tryname[0] == '.' && tryname[1] == '/')
3289                             tryname += 2;
3290                         break;
3291                     }
3292                 }
3293             }
3294         }
3295     }
3296     SAVECOPFILE_FREE(&PL_compiling);
3297     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3298     SvREFCNT_dec(namesv);
3299     if (!tryrsfp) {
3300         if (PL_op->op_type == OP_REQUIRE) {
3301             char *msgstr = name;
3302             if (namesv) {                       /* did we lookup @INC? */
3303                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3304                 SV *dirmsgsv = NEWSV(0, 0);
3305                 AV *ar = GvAVn(PL_incgv);
3306                 I32 i;
3307                 sv_catpvn(msg, " in @INC", 8);
3308                 if (instr(SvPVX(msg), ".h "))
3309                     sv_catpv(msg, " (change .h to .ph maybe?)");
3310                 if (instr(SvPVX(msg), ".ph "))
3311                     sv_catpv(msg, " (did you run h2ph?)");
3312                 sv_catpv(msg, " (@INC contains:");
3313                 for (i = 0; i <= AvFILL(ar); i++) {
3314                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3315                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3316                     sv_catsv(msg, dirmsgsv);
3317                 }
3318                 sv_catpvn(msg, ")", 1);
3319                 SvREFCNT_dec(dirmsgsv);
3320                 msgstr = SvPV_nolen(msg);
3321             }
3322             DIE(aTHX_ "Can't locate %s", msgstr);
3323         }
3324
3325         RETPUSHUNDEF;
3326     }
3327     else
3328         SETERRNO(0, SS$_NORMAL);
3329
3330     /* Assume success here to prevent recursive requirement. */
3331     len = strlen(name);
3332     /* Check whether a hook in @INC has already filled %INC */
3333     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3334         (void)hv_store(GvHVn(PL_incgv), name, len,
3335                        (hook_sv ? SvREFCNT_inc(hook_sv)
3336                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3337                        0 );
3338     }
3339
3340     ENTER;
3341     SAVETMPS;
3342     lex_start(sv_2mortal(newSVpvn("",0)));
3343     SAVEGENERICSV(PL_rsfp_filters);
3344     PL_rsfp_filters = Nullav;
3345
3346     PL_rsfp = tryrsfp;
3347     SAVEHINTS();
3348     PL_hints = 0;
3349     SAVESPTR(PL_compiling.cop_warnings);
3350     if (PL_dowarn & G_WARN_ALL_ON)
3351         PL_compiling.cop_warnings = pWARN_ALL ;
3352     else if (PL_dowarn & G_WARN_ALL_OFF)
3353         PL_compiling.cop_warnings = pWARN_NONE ;
3354     else
3355         PL_compiling.cop_warnings = pWARN_STD ;
3356     SAVESPTR(PL_compiling.cop_io);
3357     PL_compiling.cop_io = Nullsv;
3358
3359     if (filter_sub || filter_child_proc) {
3360         SV *datasv = filter_add(run_user_filter, Nullsv);
3361         IoLINES(datasv) = filter_has_file;
3362         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3363         IoTOP_GV(datasv) = (GV *)filter_state;
3364         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3365     }
3366
3367     /* switch to eval mode */
3368     push_return(PL_op->op_next);
3369     PUSHBLOCK(cx, CXt_EVAL, SP);
3370     PUSHEVAL(cx, name, Nullgv);
3371
3372     SAVECOPLINE(&PL_compiling);
3373     CopLINE_set(&PL_compiling, 0);
3374
3375     PUTBACK;
3376 #ifdef USE_5005THREADS
3377     MUTEX_LOCK(&PL_eval_mutex);
3378     if (PL_eval_owner && PL_eval_owner != thr)
3379         while (PL_eval_owner)
3380             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3381     PL_eval_owner = thr;
3382     MUTEX_UNLOCK(&PL_eval_mutex);
3383 #endif /* USE_5005THREADS */
3384
3385     /* Store and reset encoding. */
3386     encoding = PL_encoding;
3387     PL_encoding = Nullsv;
3388
3389     op = DOCATCH(doeval(gimme, NULL));
3390
3391     /* Restore encoding. */
3392     PL_encoding = encoding;
3393
3394     return op;
3395 }
3396
3397 PP(pp_dofile)
3398 {
3399     return pp_require();
3400 }
3401
3402 PP(pp_entereval)
3403 {
3404     dSP;
3405     register PERL_CONTEXT *cx;
3406     dPOPss;
3407     I32 gimme = GIMME_V, was = PL_sub_generation;
3408     char tbuf[TYPE_DIGITS(long) + 12];
3409     char *tmpbuf = tbuf;
3410     char *safestr;
3411     STRLEN len;
3412     OP *ret;
3413
3414     if (!SvPV(sv,len) || !len)
3415         RETPUSHUNDEF;
3416     TAINT_PROPER("eval");
3417
3418     ENTER;
3419     lex_start(sv);
3420     SAVETMPS;
3421
3422     /* switch to eval mode */
3423
3424     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3425         SV *sv = sv_newmortal();
3426         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3427                        (unsigned long)++PL_evalseq,
3428                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3429         tmpbuf = SvPVX(sv);
3430     }
3431     else
3432         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3433     SAVECOPFILE_FREE(&PL_compiling);
3434     CopFILE_set(&PL_compiling, tmpbuf+2);
3435     SAVECOPLINE(&PL_compiling);
3436     CopLINE_set(&PL_compiling, 1);
3437     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3438        deleting the eval's FILEGV from the stash before gv_check() runs
3439        (i.e. before run-time proper). To work around the coredump that
3440        ensues, we always turn GvMULTI_on for any globals that were
3441        introduced within evals. See force_ident(). GSAR 96-10-12 */
3442     safestr = savepv(tmpbuf);
3443     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3444     SAVEHINTS();
3445     PL_hints = PL_op->op_targ;
3446     SAVESPTR(PL_compiling.cop_warnings);
3447     if (specialWARN(PL_curcop->cop_warnings))
3448         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3449     else {
3450         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3451         SAVEFREESV(PL_compiling.cop_warnings);
3452     }
3453     SAVESPTR(PL_compiling.cop_io);
3454     if (specialCopIO(PL_curcop->cop_io))
3455         PL_compiling.cop_io = PL_curcop->cop_io;
3456     else {
3457         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3458         SAVEFREESV(PL_compiling.cop_io);
3459     }
3460
3461     push_return(PL_op->op_next);
3462     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3463     PUSHEVAL(cx, 0, Nullgv);
3464
3465     /* prepare to compile string */
3466
3467     if (PERLDB_LINE && PL_curstash != PL_debstash)
3468         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3469     PUTBACK;
3470 #ifdef USE_5005THREADS
3471     MUTEX_LOCK(&PL_eval_mutex);
3472     if (PL_eval_owner && PL_eval_owner != thr)
3473         while (PL_eval_owner)
3474             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3475     PL_eval_owner = thr;
3476     MUTEX_UNLOCK(&PL_eval_mutex);
3477 #endif /* USE_5005THREADS */
3478     ret = doeval(gimme, NULL);
3479     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3480         && ret != PL_op->op_next) {     /* Successive compilation. */
3481         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3482     }
3483     return DOCATCH(ret);
3484 }
3485
3486 PP(pp_leaveeval)
3487 {
3488     dSP;
3489     register SV **mark;
3490     SV **newsp;
3491     PMOP *newpm;
3492     I32 gimme;
3493     register PERL_CONTEXT *cx;
3494     OP *retop;
3495     U8 save_flags = PL_op -> op_flags;
3496     I32 optype;
3497
3498     POPBLOCK(cx,newpm);
3499     POPEVAL(cx);
3500     retop = pop_return();
3501
3502     TAINT_NOT;
3503     if (gimme == G_VOID)
3504         MARK = newsp;
3505     else if (gimme == G_SCALAR) {
3506         MARK = newsp + 1;
3507         if (MARK <= SP) {
3508             if (SvFLAGS(TOPs) & SVs_TEMP)
3509                 *MARK = TOPs;
3510             else
3511                 *MARK = sv_mortalcopy(TOPs);
3512         }
3513         else {
3514             MEXTEND(mark,0);
3515             *MARK = &PL_sv_undef;
3516         }
3517         SP = MARK;
3518     }
3519     else {
3520         /* in case LEAVE wipes old return values */
3521         for (mark = newsp + 1; mark <= SP; mark++) {
3522             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3523                 *mark = sv_mortalcopy(*mark);
3524                 TAINT_NOT;      /* Each item is independent */
3525             }
3526         }
3527     }
3528     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3529
3530 #ifdef DEBUGGING
3531     assert(CvDEPTH(PL_compcv) == 1);
3532 #endif
3533     CvDEPTH(PL_compcv) = 0;
3534     lex_end();
3535
3536     if (optype == OP_REQUIRE &&
3537         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3538     {
3539         /* Unassume the success we assumed earlier. */
3540         SV *nsv = cx->blk_eval.old_namesv;
3541         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3542         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3543         /* die_where() did LEAVE, or we won't be here */
3544     }
3545     else {
3546         LEAVE;
3547         if (!(save_flags & OPf_SPECIAL))
3548             sv_setpv(ERRSV,"");
3549     }
3550
3551     RETURNOP(retop);
3552 }
3553
3554 PP(pp_entertry)
3555 {
3556     dSP;
3557     register PERL_CONTEXT *cx;
3558     I32 gimme = GIMME_V;
3559
3560     ENTER;
3561     SAVETMPS;
3562
3563     push_return(cLOGOP->op_other->op_next);
3564     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3565     PUSHEVAL(cx, 0, 0);
3566
3567     PL_in_eval = EVAL_INEVAL;
3568     sv_setpv(ERRSV,"");
3569     PUTBACK;
3570     return DOCATCH(PL_op->op_next);
3571 }
3572
3573 PP(pp_leavetry)
3574 {
3575     dSP;
3576     register SV **mark;
3577     SV **newsp;
3578     PMOP *newpm;
3579     I32 gimme;
3580     register PERL_CONTEXT *cx;
3581     I32 optype;
3582
3583     POPBLOCK(cx,newpm);
3584     POPEVAL(cx);
3585     pop_return();
3586
3587     TAINT_NOT;
3588     if (gimme == G_VOID)
3589         SP = newsp;
3590     else if (gimme == G_SCALAR) {
3591         MARK = newsp + 1;
3592         if (MARK <= SP) {
3593             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3594                 *MARK = TOPs;
3595             else
3596                 *MARK = sv_mortalcopy(TOPs);
3597         }
3598         else {
3599             MEXTEND(mark,0);
3600             *MARK = &PL_sv_undef;
3601         }
3602         SP = MARK;
3603     }
3604     else {
3605         /* in case LEAVE wipes old return values */
3606         for (mark = newsp + 1; mark <= SP; mark++) {
3607             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3608                 *mark = sv_mortalcopy(*mark);
3609                 TAINT_NOT;      /* Each item is independent */
3610             }
3611         }
3612     }
3613     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3614
3615     LEAVE;
3616     sv_setpv(ERRSV,"");
3617     RETURN;
3618 }
3619
3620 STATIC void
3621 S_doparseform(pTHX_ SV *sv)
3622 {
3623     STRLEN len;
3624     register char *s = SvPV_force(sv, len);
3625     register char *send = s + len;
3626     register char *base = Nullch;
3627     register I32 skipspaces = 0;
3628     bool noblank   = FALSE;
3629     bool repeat    = FALSE;
3630     bool postspace = FALSE;
3631     U16 *fops;
3632     register U16 *fpc;
3633     U16 *linepc = 0;
3634     register I32 arg;
3635     bool ischop;
3636
3637     if (len == 0)
3638         Perl_croak(aTHX_ "Null picture in formline");
3639
3640     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3641     fpc = fops;
3642
3643     if (s < send) {
3644         linepc = fpc;
3645         *fpc++ = FF_LINEMARK;
3646         noblank = repeat = FALSE;
3647         base = s;
3648     }
3649
3650     while (s <= send) {
3651         switch (*s++) {
3652         default:
3653             skipspaces = 0;
3654             continue;
3655
3656         case '~':
3657             if (*s == '~') {
3658                 repeat = TRUE;
3659                 *s = ' ';
3660             }
3661             noblank = TRUE;
3662             s[-1] = ' ';
3663             /* FALL THROUGH */
3664         case ' ': case '\t':
3665             skipspaces++;
3666             continue;
3667
3668         case '\n': case 0:
3669             arg = s - base;
3670             skipspaces++;
3671             arg -= skipspaces;
3672             if (arg) {
3673                 if (postspace)
3674                     *fpc++ = FF_SPACE;
3675                 *fpc++ = FF_LITERAL;
3676                 *fpc++ = arg;
3677             }
3678             postspace = FALSE;
3679             if (s <= send)
3680                 skipspaces--;
3681             if (skipspaces) {
3682                 *fpc++ = FF_SKIP;
3683                 *fpc++ = skipspaces;
3684             }
3685             skipspaces = 0;
3686             if (s <= send)
3687                 *fpc++ = FF_NEWLINE;
3688             if (noblank) {
3689                 *fpc++ = FF_BLANK;
3690                 if (repeat)
3691                     arg = fpc - linepc + 1;
3692                 else
3693                     arg = 0;
3694                 *fpc++ = arg;
3695             }
3696             if (s < send) {
3697                 linepc = fpc;
3698                 *fpc++ = FF_LINEMARK;
3699                 noblank = repeat = FALSE;
3700                 base = s;
3701             }
3702             else
3703                 s++;
3704             continue;
3705
3706         case '@':
3707         case '^':
3708             ischop = s[-1] == '^';
3709
3710             if (postspace) {
3711                 *fpc++ = FF_SPACE;
3712                 postspace = FALSE;
3713             }
3714             arg = (s - base) - 1;
3715             if (arg) {
3716                 *fpc++ = FF_LITERAL;
3717                 *fpc++ = arg;
3718             }
3719
3720             base = s - 1;
3721             *fpc++ = FF_FETCH;
3722             if (*s == '*') {
3723                 s++;
3724                 *fpc++ = 0;
3725                 *fpc++ = FF_LINEGLOB;
3726             }
3727             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3728                 arg = ischop ? 512 : 0;
3729                 base = s - 1;
3730                 while (*s == '#')
3731                     s++;
3732                 if (*s == '.') {
3733                     char *f;
3734                     s++;
3735                     f = s;
3736                     while (*s == '#')
3737                         s++;
3738                     arg |= 256 + (s - f);
3739                 }
3740                 *fpc++ = s - base;              /* fieldsize for FETCH */
3741                 *fpc++ = FF_DECIMAL;
3742                 *fpc++ = arg;
3743             }
3744             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3745                 arg = ischop ? 512 : 0;
3746                 base = s - 1;
3747                 s++;                                /* skip the '0' first */
3748                 while (*s == '#')
3749                     s++;
3750                 if (*s == '.') {
3751                     char *f;
3752                     s++;
3753                     f = s;
3754                     while (*s == '#')
3755                         s++;
3756                     arg |= 256 + (s - f);
3757                 }
3758                 *fpc++ = s - base;                /* fieldsize for FETCH */
3759                 *fpc++ = FF_0DECIMAL;
3760                 *fpc++ = arg;
3761             }
3762             else {
3763                 I32 prespace = 0;
3764                 bool ismore = FALSE;
3765
3766                 if (*s == '>') {
3767                     while (*++s == '>') ;
3768                     prespace = FF_SPACE;
3769                 }
3770                 else if (*s == '|') {
3771                     while (*++s == '|') ;
3772                     prespace = FF_HALFSPACE;
3773                     postspace = TRUE;
3774                 }
3775                 else {
3776                     if (*s == '<')
3777                         while (*++s == '<') ;
3778                     postspace = TRUE;
3779                 }
3780                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3781                     s += 3;
3782                     ismore = TRUE;
3783                 }
3784                 *fpc++ = s - base;              /* fieldsize for FETCH */
3785
3786                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3787
3788                 if (prespace)
3789                     *fpc++ = prespace;
3790                 *fpc++ = FF_ITEM;
3791                 if (ismore)
3792                     *fpc++ = FF_MORE;
3793                 if (ischop)
3794                     *fpc++ = FF_CHOP;
3795             }
3796             base = s;
3797             skipspaces = 0;
3798             continue;
3799         }
3800     }
3801     *fpc++ = FF_END;
3802
3803     arg = fpc - fops;
3804     { /* need to jump to the next word */
3805         int z;
3806         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3807         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3808         s = SvPVX(sv) + SvCUR(sv) + z;
3809     }
3810     Copy(fops, s, arg, U16);
3811     Safefree(fops);
3812     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3813     SvCOMPILED_on(sv);
3814 }
3815
3816 /*
3817  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3818  *
3819  * The original code was written in conjunction with BSD Computer Software
3820  * Research Group at University of California, Berkeley.
3821  *
3822  * See also: "Optimistic Merge Sort" (SODA '92)
3823  *
3824  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3825  *
3826  * The code can be distributed under the same terms as Perl itself.
3827  *
3828  */
3829
3830 #ifdef  TESTHARNESS
3831 #include <sys/types.h>
3832 typedef void SV;
3833 #define pTHX_
3834 #define STATIC
3835 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3836 #define Safefree(VAR) free(VAR)
3837 typedef int  (*SVCOMPARE_t) (pTHX_ SV*, SV*);
3838 #endif  /* TESTHARNESS */
3839
3840 typedef char * aptr;            /* pointer for arithmetic on sizes */
3841 typedef SV * gptr;              /* pointers in our lists */
3842
3843 /* Binary merge internal sort, with a few special mods
3844 ** for the special perl environment it now finds itself in.
3845 **
3846 ** Things that were once options have been hotwired
3847 ** to values suitable for this use.  In particular, we'll always
3848 ** initialize looking for natural runs, we'll always produce stable
3849 ** output, and we'll always do Peter McIlroy's binary merge.
3850 */
3851
3852 /* Pointer types for arithmetic and storage and convenience casts */
3853
3854 #define APTR(P) ((aptr)(P))
3855 #define GPTP(P) ((gptr *)(P))
3856 #define GPPP(P) ((gptr **)(P))
3857
3858
3859 /* byte offset from pointer P to (larger) pointer Q */
3860 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3861
3862 #define PSIZE sizeof(gptr)
3863
3864 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3865
3866 #ifdef  PSHIFT
3867 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
3868 #define PNBYTE(N)       ((N) << (PSHIFT))
3869 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
3870 #else
3871 /* Leave optimization to compiler */
3872 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
3873 #define PNBYTE(N)       ((N) * (PSIZE))
3874 #define PINDEX(P, N)    (GPTP(P) + (N))
3875 #endif
3876
3877 /* Pointer into other corresponding to pointer into this */
3878 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3879
3880 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3881
3882
3883 /* Runs are identified by a pointer in the auxilliary list.
3884 ** The pointer is at the start of the list,
3885 ** and it points to the start of the next list.
3886 ** NEXT is used as an lvalue, too.
3887 */
3888
3889 #define NEXT(P)         (*GPPP(P))
3890
3891
3892 /* PTHRESH is the minimum number of pairs with the same sense to justify
3893 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
3894 ** not just elements, so PTHRESH == 8 means a run of 16.
3895 */
3896
3897 #define PTHRESH (8)
3898
3899 /* RTHRESH is the number of elements in a run that must compare low
3900 ** to the low element from the opposing run before we justify
3901 ** doing a binary rampup instead of single stepping.
3902 ** In random input, N in a row low should only happen with
3903 ** probability 2^(1-N), so we can risk that we are dealing
3904 ** with orderly input without paying much when we aren't.
3905 */
3906
3907 #define RTHRESH (6)
3908
3909
3910 /*
3911 ** Overview of algorithm and variables.
3912 ** The array of elements at list1 will be organized into runs of length 2,
3913 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
3914 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3915 **
3916 ** Unless otherwise specified, pair pointers address the first of two elements.
3917 **
3918 ** b and b+1 are a pair that compare with sense ``sense''.
3919 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3920 **
3921 ** p2 parallels b in the list2 array, where runs are defined by
3922 ** a pointer chain.
3923 **
3924 ** t represents the ``top'' of the adjacent pairs that might extend
3925 ** the run beginning at b.  Usually, t addresses a pair
3926 ** that compares with opposite sense from (b,b+1).
3927 ** However, it may also address a singleton element at the end of list1,
3928 ** or it may be equal to ``last'', the first element beyond list1.
3929 **
3930 ** r addresses the Nth pair following b.  If this would be beyond t,
3931 ** we back it off to t.  Only when r is less than t do we consider the
3932 ** run long enough to consider checking.
3933 **
3934 ** q addresses a pair such that the pairs at b through q already form a run.
3935 ** Often, q will equal b, indicating we only are sure of the pair itself.
3936 ** However, a search on the previous cycle may have revealed a longer run,
3937 ** so q may be greater than b.
3938 **
3939 ** p is used to work back from a candidate r, trying to reach q,
3940 ** which would mean b through r would be a run.  If we discover such a run,
3941 ** we start q at r and try to push it further towards t.
3942 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3943 ** In any event, after the check (if any), we have two main cases.
3944 **
3945 ** 1) Short run.  b <= q < p <= r <= t.
3946 **      b through q is a run (perhaps trivial)
3947 **      q through p are uninteresting pairs
3948 **      p through r is a run
3949 **
3950 ** 2) Long run.  b < r <= q < t.
3951 **      b through q is a run (of length >= 2 * PTHRESH)
3952 **
3953 ** Note that degenerate cases are not only possible, but likely.
3954 ** For example, if the pair following b compares with opposite sense,
3955 ** then b == q < p == r == t.
3956 */
3957
3958
3959 static void
3960 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3961 {
3962     int sense;
3963     register gptr *b, *p, *q, *t, *p2;
3964     register gptr c, *last, *r;
3965     gptr *savep;
3966
3967     b = list1;
3968     last = PINDEX(b, nmemb);
3969     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3970     for (p2 = list2; b < last; ) {
3971         /* We just started, or just reversed sense.
3972         ** Set t at end of pairs with the prevailing sense.
3973         */
3974         for (p = b+2, t = p; ++p < last; t = ++p) {
3975             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3976         }
3977         q = b;
3978         /* Having laid out the playing field, look for long runs */
3979         do {
3980             p = r = b + (2 * PTHRESH);
3981             if (r >= t) p = r = t;      /* too short to care about */
3982             else {
3983                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3984                        ((p -= 2) > q));
3985                 if (p <= q) {
3986                     /* b through r is a (long) run.
3987                     ** Extend it as far as possible.
3988                     */
3989                     p = q = r;
3990                     while (((p += 2) < t) &&
3991                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3992                     r = p = q + 2;      /* no simple pairs, no after-run */
3993                 }
3994             }
3995             if (q > b) {                /* run of greater than 2 at b */
3996                 savep = p;
3997                 p = q += 2;
3998                 /* pick up singleton, if possible */
3999                 if ((p == t) &&
4000                     ((t + 1) == last) &&
4001                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
4002                     savep = r = p = q = last;
4003                 p2 = NEXT(p2) = p2 + (p - b);
4004                 if (sense) while (b < --p) {
4005                     c = *b;
4006                     *b++ = *p;
4007                     *p = c;
4008                 }
4009                 p = savep;
4010             }
4011             while (q < p) {             /* simple pairs */
4012                 p2 = NEXT(p2) = p2 + 2;
4013                 if (sense) {
4014                     c = *q++;
4015                     *(q-1) = *q;
4016                     *q++ = c;
4017                 } else q += 2;
4018             }
4019             if (((b = p) == t) && ((t+1) == last)) {
4020                 NEXT(p2) = p2 + 1;
4021                 b++;
4022             }
4023             q = r;
4024         } while (b < t);
4025         sense = !sense;
4026     }
4027     return;
4028 }
4029
4030
4031 /* Overview of bmerge variables:
4032 **
4033 ** list1 and list2 address the main and auxiliary arrays.
4034 ** They swap identities after each merge pass.
4035 ** Base points to the original list1, so we can tell if
4036 ** the pointers ended up where they belonged (or must be copied).
4037 **
4038 ** When we are merging two lists, f1 and f2 are the next elements
4039 ** on the respective lists.  l1 and l2 mark the end of the lists.
4040 ** tp2 is the current location in the merged list.
4041 **
4042 ** p1 records where f1 started.
4043 ** After the merge, a new descriptor is built there.
4044 **
4045 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4046 ** It is used to identify and delimit the runs.
4047 **
4048 ** In the heat of determining where q, the greater of the f1/f2 elements,
4049 ** belongs in the other list, b, t and p, represent bottom, top and probe
4050 ** locations, respectively, in the other list.
4051 ** They make convenient temporary pointers in other places.
4052 */
4053
4054 /*
4055 =for apidoc sortsv
4056
4057 Sort an array. Here is an example:
4058
4059     sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
4060
4061 =cut
4062 */
4063
4064 void
4065 Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4066 {
4067     int i, run;
4068     int sense;
4069     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4070     gptr *aux, *list2, *p2, *last;
4071     gptr *base = list1;
4072     gptr *p1;
4073
4074     if (nmemb <= 1) return;     /* sorted trivially */
4075     New(799,list2,nmemb,gptr);  /* allocate auxilliary array */
4076     aux = list2;
4077     dynprep(aTHX_ list1, list2, nmemb, cmp);
4078     last = PINDEX(list2, nmemb);
4079     while (NEXT(list2) != last) {
4080         /* More than one run remains.  Do some merging to reduce runs. */
4081         l2 = p1 = list1;
4082         for (tp2 = p2 = list2; p2 != last;) {
4083             /* The new first run begins where the old second list ended.
4084             ** Use the p2 ``parallel'' pointer to identify the end of the run.
4085             */
4086             f1 = l2;
4087             t = NEXT(p2);
4088             f2 = l1 = POTHER(t, list2, list1);
4089             if (t != last) t = NEXT(t);
4090             l2 = POTHER(t, list2, list1);
4091             p2 = t;
4092             while (f1 < l1 && f2 < l2) {
4093                 /* If head 1 is larger than head 2, find ALL the elements
4094                 ** in list 2 strictly less than head1, write them all,
4095                 ** then head 1.  Then compare the new heads, and repeat,
4096                 ** until one or both lists are exhausted.
4097                 **
4098                 ** In all comparisons (after establishing
4099                 ** which head to merge) the item to merge
4100                 ** (at pointer q) is the first operand of
4101                 ** the comparison.  When we want to know
4102                 ** if ``q is strictly less than the other'',
4103                 ** we can't just do
4104                 **    cmp(q, other) < 0
4105                 ** because stability demands that we treat equality
4106                 ** as high when q comes from l2, and as low when
4107                 ** q was from l1.  So we ask the question by doing
4108                 **    cmp(q, other) <= sense
4109                 ** and make sense == 0 when equality should look low,
4110                 ** and -1 when equality should look high.
4111                 */
4112
4113
4114                 if (cmp(aTHX_ *f1, *f2) <= 0) {
4115                     q = f2; b = f1; t = l1;
4116                     sense = -1;
4117                 } else {
4118                     q = f1; b = f2; t = l2;
4119                     sense = 0;
4120                 }
4121
4122
4123                 /* ramp up
4124                 **
4125                 ** Leave t at something strictly
4126                 ** greater than q (or at the end of the list),
4127                 ** and b at something strictly less than q.
4128                 */
4129                 for (i = 1, run = 0 ;;) {
4130                     if ((p = PINDEX(b, i)) >= t) {
4131                         /* off the end */
4132                         if (((p = PINDEX(t, -1)) > b) &&
4133                             (cmp(aTHX_ *q, *p) <= sense))
4134                              t = p;
4135                         else b = p;
4136                         break;
4137                     } else if (cmp(aTHX_ *q, *p) <= sense) {
4138                         t = p;
4139                         break;
4140                     } else b = p;
4141                     if (++run >= RTHRESH) i += i;
4142                 }
4143
4144
4145                 /* q is known to follow b and must be inserted before t.
4146                 ** Increment b, so the range of possibilities is [b,t).
4147                 ** Round binary split down, to favor early appearance.
4148                 ** Adjust b and t until q belongs just before t.
4149                 */
4150
4151                 b++;
4152                 while (b < t) {
4153                     p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4154                     if (cmp(aTHX_ *q, *p) <= sense) {
4155                         t = p;
4156                     } else b = p + 1;
4157                 }
4158
4159
4160                 /* Copy all the strictly low elements */
4161
4162                 if (q == f1) {
4163                     FROMTOUPTO(f2, tp2, t);
4164                     *tp2++ = *f1++;
4165                 } else {
4166                     FROMTOUPTO(f1, tp2, t);
4167                     *tp2++ = *f2++;
4168                 }
4169             }
4170
4171
4172             /* Run out remaining list */
4173             if (f1 == l1) {
4174                    if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4175             } else              FROMTOUPTO(f1, tp2, l1);
4176             p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4177         }
4178         t = list1;
4179         list1 = list2;
4180         list2 = t;
4181         last = PINDEX(list2, nmemb);
4182     }
4183     if (base == list2) {
4184         last = PINDEX(list1, nmemb);
4185         FROMTOUPTO(list1, list2, last);
4186     }
4187     Safefree(aux);
4188     return;
4189 }
4190
4191 static I32
4192 sortcv(pTHX_ SV *a, SV *b)
4193 {
4194     I32 oldsaveix = PL_savestack_ix;
4195     I32 oldscopeix = PL_scopestack_ix;
4196     I32 result;
4197     GvSV(PL_firstgv) = a;
4198     GvSV(PL_secondgv) = b;
4199     PL_stack_sp = PL_stack_base;
4200     PL_op = PL_sortcop;
4201     CALLRUNOPS(aTHX);
4202     if (PL_stack_sp != PL_stack_base + 1)
4203         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4204     if (!SvNIOKp(*PL_stack_sp))
4205         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4206     result = SvIV(*PL_stack_sp);
4207     while (PL_scopestack_ix > oldscopeix) {
4208         LEAVE;
4209     }
4210     leave_scope(oldsaveix);
4211     return result;
4212 }
4213
4214 static I32
4215 sortcv_stacked(pTHX_ SV *a, SV *b)
4216 {
4217     I32 oldsaveix = PL_savestack_ix;
4218     I32 oldscopeix = PL_scopestack_ix;
4219     I32 result;
4220     AV *av;
4221
4222 #ifdef USE_5005THREADS
4223     av = (AV*)PL_curpad[0];
4224 #else
4225     av = GvAV(PL_defgv);
4226 #endif
4227
4228     if (AvMAX(av) < 1) {
4229         SV** ary = AvALLOC(av);
4230         if (AvARRAY(av) != ary) {
4231             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4232             SvPVX(av) = (char*)ary;
4233         }
4234         if (AvMAX(av) < 1) {
4235             AvMAX(av) = 1;
4236             Renew(ary,2,SV*);
4237             SvPVX(av) = (char*)ary;
4238         }
4239     }
4240     AvFILLp(av) = 1;
4241
4242     AvARRAY(av)[0] = a;
4243     AvARRAY(av)[1] = b;
4244     PL_stack_sp = PL_stack_base;
4245     PL_op = PL_sortcop;
4246     CALLRUNOPS(aTHX);
4247     if (PL_stack_sp != PL_stack_base + 1)
4248         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4249     if (!SvNIOKp(*PL_stack_sp))
4250         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4251     result = SvIV(*PL_stack_sp);
4252     while (PL_scopestack_ix > oldscopeix) {
4253         LEAVE;
4254     }
4255     leave_scope(oldsaveix);
4256     return result;
4257 }
4258
4259 static I32
4260 sortcv_xsub(pTHX_ SV *a, SV *b)
4261 {
4262     dSP;
4263     I32 oldsaveix = PL_savestack_ix;
4264     I32 oldscopeix = PL_scopestack_ix;
4265     I32 result;
4266     CV *cv=(CV*)PL_sortcop;
4267
4268     SP = PL_stack_base;
4269     PUSHMARK(SP);
4270     EXTEND(SP, 2);
4271     *++SP = a;
4272     *++SP = b;
4273     PUTBACK;
4274     (void)(*CvXSUB(cv))(aTHX_ cv);
4275     if (PL_stack_sp != PL_stack_base + 1)
4276         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4277     if (!SvNIOKp(*PL_stack_sp))
4278         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4279     result = SvIV(*PL_stack_sp);
4280     while (PL_scopestack_ix > oldscopeix) {
4281         LEAVE;
4282     }
4283     leave_scope(oldsaveix);
4284     return result;
4285 }
4286
4287
4288 static I32
4289 sv_ncmp(pTHX_ SV *a, SV *b)
4290 {
4291     NV nv1 = SvNV(a);
4292     NV nv2 = SvNV(b);
4293     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4294 }
4295
4296 static I32
4297 sv_i_ncmp(pTHX_ SV *a, SV *b)
4298 {
4299     IV iv1 = SvIV(a);
4300     IV iv2 = SvIV(b);
4301     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4302 }
4303 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4304           *svp = Nullsv;                                \
4305           if (PL_amagic_generation) { \
4306             if (SvAMAGIC(left)||SvAMAGIC(right))\
4307                 *svp = amagic_call(left, \
4308                                    right, \
4309                                    CAT2(meth,_amg), \
4310                                    0); \
4311           } \
4312         } STMT_END
4313
4314 static I32
4315 amagic_ncmp(pTHX_ register SV *a, register SV *b)
4316 {
4317     SV *tmpsv;
4318     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4319     if (tmpsv) {
4320         NV d;
4321
4322         if (SvIOK(tmpsv)) {
4323             I32 i = SvIVX(tmpsv);
4324             if (i > 0)
4325                return 1;
4326             return i? -1 : 0;
4327         }
4328         d = SvNV(tmpsv);
4329         if (d > 0)
4330            return 1;
4331         return d? -1 : 0;
4332      }
4333      return sv_ncmp(aTHX_ a, b);
4334 }
4335
4336 static I32
4337 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
4338 {
4339     SV *tmpsv;
4340     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4341     if (tmpsv) {
4342         NV d;
4343
4344         if (SvIOK(tmpsv)) {
4345             I32 i = SvIVX(tmpsv);
4346             if (i > 0)
4347                return 1;
4348             return i? -1 : 0;
4349         }
4350         d = SvNV(tmpsv);
4351         if (d > 0)
4352            return 1;
4353         return d? -1 : 0;
4354     }
4355     return sv_i_ncmp(aTHX_ a, b);
4356 }
4357
4358 static I32
4359 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
4360 {
4361     SV *tmpsv;
4362     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4363     if (tmpsv) {
4364         NV d;
4365
4366         if (SvIOK(tmpsv)) {
4367             I32 i = SvIVX(tmpsv);
4368             if (i > 0)
4369                return 1;
4370             return i? -1 : 0;
4371         }
4372         d = SvNV(tmpsv);
4373         if (d > 0)
4374            return 1;
4375         return d? -1 : 0;
4376     }
4377     return sv_cmp(str1, str2);
4378 }
4379
4380 static I32
4381 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
4382 {
4383     SV *tmpsv;
4384     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4385     if (tmpsv) {
4386         NV d;
4387
4388         if (SvIOK(tmpsv)) {
4389             I32 i = SvIVX(tmpsv);
4390             if (i > 0)
4391                return 1;
4392             return i? -1 : 0;
4393         }
4394         d = SvNV(tmpsv);
4395         if (d > 0)
4396            return 1;
4397         return d? -1 : 0;
4398     }
4399     return sv_cmp_locale(str1, str2);
4400 }
4401
4402 static I32
4403 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4404 {
4405     SV *datasv = FILTER_DATA(idx);
4406     int filter_has_file = IoLINES(datasv);
4407     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4408     SV *filter_state = (SV *)IoTOP_GV(datasv);
4409     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4410     int len = 0;
4411
4412     /* I was having segfault trouble under Linux 2.2.5 after a
4413        parse error occured.  (Had to hack around it with a test
4414        for PL_error_count == 0.)  Solaris doesn't segfault --
4415        not sure where the trouble is yet.  XXX */
4416
4417     if (filter_has_file) {
4418         len = FILTER_READ(idx+1, buf_sv, maxlen);
4419     }
4420
4421     if (filter_sub && len >= 0) {
4422         dSP;
4423         int count;
4424
4425         ENTER;
4426         SAVE_DEFSV;
4427         SAVETMPS;
4428         EXTEND(SP, 2);
4429
4430         DEFSV = buf_sv;
4431         PUSHMARK(SP);
4432         PUSHs(sv_2mortal(newSViv(maxlen)));
4433         if (filter_state) {
4434             PUSHs(filter_state);
4435         }
4436         PUTBACK;
4437         count = call_sv(filter_sub, G_SCALAR);
4438         SPAGAIN;
4439
4440         if (count > 0) {
4441             SV *out = POPs;
4442             if (SvOK(out)) {
4443                 len = SvIV(out);
4444             }
4445         }
4446
4447         PUTBACK;
4448         FREETMPS;
4449         LEAVE;
4450     }
4451
4452     if (len <= 0) {
4453         IoLINES(datasv) = 0;
4454         if (filter_child_proc) {
4455             SvREFCNT_dec(filter_child_proc);
4456             IoFMT_GV(datasv) = Nullgv;
4457         }
4458         if (filter_state) {
4459             SvREFCNT_dec(filter_state);
4460             IoTOP_GV(datasv) = Nullgv;
4461         }
4462         if (filter_sub) {
4463             SvREFCNT_dec(filter_sub);
4464             IoBOTTOM_GV(datasv) = Nullgv;
4465         }
4466         filter_del(run_user_filter);
4467     }
4468
4469     return len;
4470 }