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 #endif
2597     }
2598     PL_exit_flags |= PERL_EXIT_EXPECTED;
2599     my_exit(anum);
2600     PUSHs(&PL_sv_undef);
2601     RETURN;
2602 }
2603
2604 #ifdef NOTYET
2605 PP(pp_nswitch)
2606 {
2607     dSP;
2608     NV value = SvNVx(GvSV(cCOP->cop_gv));
2609     register I32 match = I_32(value);
2610
2611     if (value < 0.0) {
2612         if (((NV)match) > value)
2613             --match;            /* was fractional--truncate other way */
2614     }
2615     match -= cCOP->uop.scop.scop_offset;
2616     if (match < 0)
2617         match = 0;
2618     else if (match > cCOP->uop.scop.scop_max)
2619         match = cCOP->uop.scop.scop_max;
2620     PL_op = cCOP->uop.scop.scop_next[match];
2621     RETURNOP(PL_op);
2622 }
2623
2624 PP(pp_cswitch)
2625 {
2626     dSP;
2627     register I32 match;
2628
2629     if (PL_multiline)
2630         PL_op = PL_op->op_next;                 /* can't assume anything */
2631     else {
2632         STRLEN n_a;
2633         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2634         match -= cCOP->uop.scop.scop_offset;
2635         if (match < 0)
2636             match = 0;
2637         else if (match > cCOP->uop.scop.scop_max)
2638             match = cCOP->uop.scop.scop_max;
2639         PL_op = cCOP->uop.scop.scop_next[match];
2640     }
2641     RETURNOP(PL_op);
2642 }
2643 #endif
2644
2645 /* Eval. */
2646
2647 STATIC void
2648 S_save_lines(pTHX_ AV *array, SV *sv)
2649 {
2650     register char *s = SvPVX(sv);
2651     register char *send = SvPVX(sv) + SvCUR(sv);
2652     register char *t;
2653     register I32 line = 1;
2654
2655     while (s && s < send) {
2656         SV *tmpstr = NEWSV(85,0);
2657
2658         sv_upgrade(tmpstr, SVt_PVMG);
2659         t = strchr(s, '\n');
2660         if (t)
2661             t++;
2662         else
2663             t = send;
2664
2665         sv_setpvn(tmpstr, s, t - s);
2666         av_store(array, line++, tmpstr);
2667         s = t;
2668     }
2669 }
2670
2671 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2672 STATIC void *
2673 S_docatch_body(pTHX_ va_list args)
2674 {
2675     return docatch_body();
2676 }
2677 #endif
2678
2679 STATIC void *
2680 S_docatch_body(pTHX)
2681 {
2682     CALLRUNOPS(aTHX);
2683     return NULL;
2684 }
2685
2686 STATIC OP *
2687 S_docatch(pTHX_ OP *o)
2688 {
2689     int ret;
2690     OP *oldop = PL_op;
2691     volatile PERL_SI *cursi = PL_curstackinfo;
2692     dJMPENV;
2693
2694 #ifdef DEBUGGING
2695     assert(CATCH_GET == TRUE);
2696 #endif
2697     PL_op = o;
2698 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2699  redo_body:
2700     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2701 #else
2702     JMPENV_PUSH(ret);
2703 #endif
2704     switch (ret) {
2705     case 0:
2706 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2707  redo_body:
2708         docatch_body();
2709 #endif
2710         break;
2711     case 3:
2712         if (PL_restartop && cursi == PL_curstackinfo) {
2713             PL_op = PL_restartop;
2714             PL_restartop = 0;
2715             goto redo_body;
2716         }
2717         /* FALL THROUGH */
2718     default:
2719         JMPENV_POP;
2720         PL_op = oldop;
2721         JMPENV_JUMP(ret);
2722         /* NOTREACHED */
2723     }
2724     JMPENV_POP;
2725     PL_op = oldop;
2726     return Nullop;
2727 }
2728
2729 OP *
2730 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2731 /* sv Text to convert to OP tree. */
2732 /* startop op_free() this to undo. */
2733 /* code Short string id of the caller. */
2734 {
2735     dSP;                                /* Make POPBLOCK work. */
2736     PERL_CONTEXT *cx;
2737     SV **newsp;
2738     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2739     I32 optype;
2740     OP dummy;
2741     OP *rop;
2742     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2743     char *tmpbuf = tbuf;
2744     char *safestr;
2745
2746     ENTER;
2747     lex_start(sv);
2748     SAVETMPS;
2749     /* switch to eval mode */
2750
2751     if (PL_curcop == &PL_compiling) {
2752         SAVECOPSTASH_FREE(&PL_compiling);
2753         CopSTASH_set(&PL_compiling, PL_curstash);
2754     }
2755     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2756         SV *sv = sv_newmortal();
2757         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2758                        code, (unsigned long)++PL_evalseq,
2759                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2760         tmpbuf = SvPVX(sv);
2761     }
2762     else
2763         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2764     SAVECOPFILE_FREE(&PL_compiling);
2765     CopFILE_set(&PL_compiling, tmpbuf+2);
2766     SAVECOPLINE(&PL_compiling);
2767     CopLINE_set(&PL_compiling, 1);
2768     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2769        deleting the eval's FILEGV from the stash before gv_check() runs
2770        (i.e. before run-time proper). To work around the coredump that
2771        ensues, we always turn GvMULTI_on for any globals that were
2772        introduced within evals. See force_ident(). GSAR 96-10-12 */
2773     safestr = savepv(tmpbuf);
2774     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2775     SAVEHINTS();
2776 #ifdef OP_IN_REGISTER
2777     PL_opsave = op;
2778 #else
2779     SAVEVPTR(PL_op);
2780 #endif
2781     PL_hints &= HINT_UTF8;
2782
2783     PL_op = &dummy;
2784     PL_op->op_type = OP_ENTEREVAL;
2785     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2786     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2787     PUSHEVAL(cx, 0, Nullgv);
2788     rop = doeval(G_SCALAR, startop);
2789     POPBLOCK(cx,PL_curpm);
2790     POPEVAL(cx);
2791
2792     (*startop)->op_type = OP_NULL;
2793     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2794     lex_end();
2795     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2796     LEAVE;
2797     if (PL_curcop == &PL_compiling)
2798         PL_compiling.op_private = PL_hints;
2799 #ifdef OP_IN_REGISTER
2800     op = PL_opsave;
2801 #endif
2802     return rop;
2803 }
2804
2805 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2806 STATIC OP *
2807 S_doeval(pTHX_ int gimme, OP** startop)
2808 {
2809     dSP;
2810     OP *saveop = PL_op;
2811     CV *caller;
2812     AV* comppadlist;
2813     I32 i;
2814
2815     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2816                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2817                   : EVAL_INEVAL);
2818
2819     PUSHMARK(SP);
2820
2821     /* set up a scratch pad */
2822
2823     SAVEI32(PL_padix);
2824     SAVEVPTR(PL_curpad);
2825     SAVESPTR(PL_comppad);
2826     SAVESPTR(PL_comppad_name);
2827     SAVEI32(PL_comppad_name_fill);
2828     SAVEI32(PL_min_intro_pending);
2829     SAVEI32(PL_max_intro_pending);
2830
2831     caller = PL_compcv;
2832     for (i = cxstack_ix - 1; i >= 0; i--) {
2833         PERL_CONTEXT *cx = &cxstack[i];
2834         if (CxTYPE(cx) == CXt_EVAL)
2835             break;
2836         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2837             caller = cx->blk_sub.cv;
2838             break;
2839         }
2840     }
2841
2842     SAVESPTR(PL_compcv);
2843     PL_compcv = (CV*)NEWSV(1104,0);
2844     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2845     CvEVAL_on(PL_compcv);
2846     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2847     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2848
2849 #ifdef USE_5005THREADS
2850     CvOWNER(PL_compcv) = 0;
2851     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2852     MUTEX_INIT(CvMUTEXP(PL_compcv));
2853 #endif /* USE_5005THREADS */
2854
2855     PL_comppad = newAV();
2856     av_push(PL_comppad, Nullsv);
2857     PL_curpad = AvARRAY(PL_comppad);
2858     PL_comppad_name = newAV();
2859     PL_comppad_name_fill = 0;
2860     PL_min_intro_pending = 0;
2861     PL_padix = 0;
2862 #ifdef USE_5005THREADS
2863     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2864     PL_curpad[0] = (SV*)newAV();
2865     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2866 #endif /* USE_5005THREADS */
2867
2868     comppadlist = newAV();
2869     AvREAL_off(comppadlist);
2870     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2871     av_store(comppadlist, 1, (SV*)PL_comppad);
2872     CvPADLIST(PL_compcv) = comppadlist;
2873
2874     if (!saveop ||
2875         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2876     {
2877         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2878     }
2879
2880     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2881
2882     /* make sure we compile in the right package */
2883
2884     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2885         SAVESPTR(PL_curstash);
2886         PL_curstash = CopSTASH(PL_curcop);
2887     }
2888     SAVESPTR(PL_beginav);
2889     PL_beginav = newAV();
2890     SAVEFREESV(PL_beginav);
2891     SAVEI32(PL_error_count);
2892
2893     /* try to compile it */
2894
2895     PL_eval_root = Nullop;
2896     PL_error_count = 0;
2897     PL_curcop = &PL_compiling;
2898     PL_curcop->cop_arybase = 0;
2899     if (saveop && saveop->op_flags & OPf_SPECIAL)
2900         PL_in_eval |= EVAL_KEEPERR;
2901     else
2902         sv_setpv(ERRSV,"");
2903     if (yyparse() || PL_error_count || !PL_eval_root) {
2904         SV **newsp;
2905         I32 gimme;
2906         PERL_CONTEXT *cx;
2907         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2908         STRLEN n_a;
2909
2910         PL_op = saveop;
2911         if (PL_eval_root) {
2912             op_free(PL_eval_root);
2913             PL_eval_root = Nullop;
2914         }
2915         SP = PL_stack_base + POPMARK;           /* pop original mark */
2916         if (!startop) {
2917             POPBLOCK(cx,PL_curpm);
2918             POPEVAL(cx);
2919             pop_return();
2920         }
2921         lex_end();
2922         LEAVE;
2923         if (optype == OP_REQUIRE) {
2924             char* msg = SvPVx(ERRSV, n_a);
2925             DIE(aTHX_ "%sCompilation failed in require",
2926                 *msg ? msg : "Unknown error\n");
2927         }
2928         else if (startop) {
2929             char* msg = SvPVx(ERRSV, n_a);
2930
2931             POPBLOCK(cx,PL_curpm);
2932             POPEVAL(cx);
2933             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2934                        (*msg ? msg : "Unknown error\n"));
2935         }
2936 #ifdef USE_5005THREADS
2937         MUTEX_LOCK(&PL_eval_mutex);
2938         PL_eval_owner = 0;
2939         COND_SIGNAL(&PL_eval_cond);
2940         MUTEX_UNLOCK(&PL_eval_mutex);
2941 #endif /* USE_5005THREADS */
2942         RETPUSHUNDEF;
2943     }
2944     CopLINE_set(&PL_compiling, 0);
2945     if (startop) {
2946         *startop = PL_eval_root;
2947         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2948         CvOUTSIDE(PL_compcv) = Nullcv;
2949     } else
2950         SAVEFREEOP(PL_eval_root);
2951     if (gimme & G_VOID)
2952         scalarvoid(PL_eval_root);
2953     else if (gimme & G_ARRAY)
2954         list(PL_eval_root);
2955     else
2956         scalar(PL_eval_root);
2957
2958     DEBUG_x(dump_eval());
2959
2960     /* Register with debugger: */
2961     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2962         CV *cv = get_cv("DB::postponed", FALSE);
2963         if (cv) {
2964             dSP;
2965             PUSHMARK(SP);
2966             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2967             PUTBACK;
2968             call_sv((SV*)cv, G_DISCARD);
2969         }
2970     }
2971
2972     /* compiled okay, so do it */
2973
2974     CvDEPTH(PL_compcv) = 1;
2975     SP = PL_stack_base + POPMARK;               /* pop original mark */
2976     PL_op = saveop;                     /* The caller may need it. */
2977     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2978 #ifdef USE_5005THREADS
2979     MUTEX_LOCK(&PL_eval_mutex);
2980     PL_eval_owner = 0;
2981     COND_SIGNAL(&PL_eval_cond);
2982     MUTEX_UNLOCK(&PL_eval_mutex);
2983 #endif /* USE_5005THREADS */
2984
2985     RETURNOP(PL_eval_start);
2986 }
2987
2988 STATIC PerlIO *
2989 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2990 {
2991     STRLEN namelen = strlen(name);
2992     PerlIO *fp;
2993
2994     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2995         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2996         char *pmc = SvPV_nolen(pmcsv);
2997         Stat_t pmstat;
2998         Stat_t pmcstat;
2999         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3000             fp = PerlIO_open(name, mode);
3001         }
3002         else {
3003             if (PerlLIO_stat(name, &pmstat) < 0 ||
3004                 pmstat.st_mtime < pmcstat.st_mtime)
3005             {
3006                 fp = PerlIO_open(pmc, mode);
3007             }
3008             else {
3009                 fp = PerlIO_open(name, mode);
3010             }
3011         }
3012         SvREFCNT_dec(pmcsv);
3013     }
3014     else {
3015         fp = PerlIO_open(name, mode);
3016     }
3017     return fp;
3018 }
3019
3020 PP(pp_require)
3021 {
3022     dSP;
3023     register PERL_CONTEXT *cx;
3024     SV *sv;
3025     char *name;
3026     STRLEN len;
3027     char *tryname = Nullch;
3028     SV *namesv = Nullsv;
3029     SV** svp;
3030     I32 gimme = GIMME_V;
3031     PerlIO *tryrsfp = 0;
3032     STRLEN n_a;
3033     int filter_has_file = 0;
3034     GV *filter_child_proc = 0;
3035     SV *filter_state = 0;
3036     SV *filter_sub = 0;
3037     SV *hook_sv = 0;
3038
3039     sv = POPs;
3040     if (SvNIOKp(sv)) {
3041         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
3042             UV rev = 0, ver = 0, sver = 0;
3043             STRLEN len;
3044             U8 *s = (U8*)SvPVX(sv);
3045             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3046             if (s < end) {
3047                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3048                 s += len;
3049                 if (s < end) {
3050                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3051                     s += len;
3052                     if (s < end)
3053                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3054                 }
3055             }
3056             if (PERL_REVISION < rev
3057                 || (PERL_REVISION == rev
3058                     && (PERL_VERSION < ver
3059                         || (PERL_VERSION == ver
3060                             && PERL_SUBVERSION < sver))))
3061             {
3062                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3063                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3064                     PERL_VERSION, PERL_SUBVERSION);
3065             }
3066             if (ckWARN(WARN_PORTABLE))
3067                 Perl_warner(aTHX_ WARN_PORTABLE,
3068                         "v-string in use/require non-portable");
3069             RETPUSHYES;
3070         }
3071         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3072             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3073                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3074                 + 0.00000099 < SvNV(sv))
3075             {
3076                 NV nrev = SvNV(sv);
3077                 UV rev = (UV)nrev;
3078                 NV nver = (nrev - rev) * 1000;
3079                 UV ver = (UV)(nver + 0.0009);
3080                 NV nsver = (nver - ver) * 1000;
3081                 UV sver = (UV)(nsver + 0.0009);
3082
3083                 /* help out with the "use 5.6" confusion */
3084                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3085                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3086                         "this is only v%d.%d.%d, stopped"
3087                         " (did you mean v%"UVuf".%03"UVuf"?)",
3088                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3089                         PERL_SUBVERSION, rev, ver/100);
3090                 }
3091                 else {
3092                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3093                         "this is only v%d.%d.%d, stopped",
3094                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3095                         PERL_SUBVERSION);
3096                 }
3097             }
3098             RETPUSHYES;
3099         }
3100     }
3101     name = SvPV(sv, len);
3102     if (!(name && len > 0 && *name))
3103         DIE(aTHX_ "Null filename used");
3104     TAINT_PROPER("require");
3105     if (PL_op->op_type == OP_REQUIRE &&
3106       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3107       *svp != &PL_sv_undef)
3108         RETPUSHYES;
3109
3110     /* prepare to compile file */
3111
3112 #ifdef MACOS_TRADITIONAL
3113     if (PERL_FILE_IS_ABSOLUTE(name)
3114         || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3115     {
3116         tryname = name;
3117         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3118         /* We consider paths of the form :a:b ambiguous and interpret them first
3119            as global then as local
3120         */
3121         if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3122             goto trylocal;
3123     }
3124     else
3125 trylocal: {
3126 #else
3127     if (PERL_FILE_IS_ABSOLUTE(name)
3128         || (*name == '.' && (name[1] == '/' ||
3129                              (name[1] == '.' && name[2] == '/'))))
3130     {
3131         tryname = name;
3132         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3133     }
3134     else {
3135 #endif
3136         AV *ar = GvAVn(PL_incgv);
3137         I32 i;
3138 #ifdef VMS
3139         char *unixname;
3140         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3141 #endif
3142         {
3143             namesv = NEWSV(806, 0);
3144             for (i = 0; i <= AvFILL(ar); i++) {
3145                 SV *dirsv = *av_fetch(ar, i, TRUE);
3146
3147                 if (SvROK(dirsv)) {
3148                     int count;
3149                     SV *loader = dirsv;
3150
3151                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3152                         && !sv_isobject(loader))
3153                     {
3154                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3155                     }
3156
3157                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3158                                    PTR2UV(SvRV(dirsv)), name);
3159                     tryname = SvPVX(namesv);
3160                     tryrsfp = 0;
3161
3162                     ENTER;
3163                     SAVETMPS;
3164                     EXTEND(SP, 2);
3165
3166                     PUSHMARK(SP);
3167                     PUSHs(dirsv);
3168                     PUSHs(sv);
3169                     PUTBACK;
3170                     if (sv_isobject(loader))
3171                         count = call_method("INC", G_ARRAY);
3172                     else
3173                         count = call_sv(loader, G_ARRAY);
3174                     SPAGAIN;
3175
3176                     if (count > 0) {
3177                         int i = 0;
3178                         SV *arg;
3179
3180                         SP -= count - 1;
3181                         arg = SP[i++];
3182
3183                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3184                             arg = SvRV(arg);
3185                         }
3186
3187                         if (SvTYPE(arg) == SVt_PVGV) {
3188                             IO *io = GvIO((GV *)arg);
3189
3190                             ++filter_has_file;
3191
3192                             if (io) {
3193                                 tryrsfp = IoIFP(io);
3194                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3195                                     /* reading from a child process doesn't
3196                                        nest -- when returning from reading
3197                                        the inner module, the outer one is
3198                                        unreadable (closed?)  I've tried to
3199                                        save the gv to manage the lifespan of
3200                                        the pipe, but this didn't help. XXX */
3201                                     filter_child_proc = (GV *)arg;
3202                                     (void)SvREFCNT_inc(filter_child_proc);
3203                                 }
3204                                 else {
3205                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3206                                         PerlIO_close(IoOFP(io));
3207                                     }
3208                                     IoIFP(io) = Nullfp;
3209                                     IoOFP(io) = Nullfp;
3210                                 }
3211                             }
3212
3213                             if (i < count) {
3214                                 arg = SP[i++];
3215                             }
3216                         }
3217
3218                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3219                             filter_sub = arg;
3220                             (void)SvREFCNT_inc(filter_sub);
3221
3222                             if (i < count) {
3223                                 filter_state = SP[i];
3224                                 (void)SvREFCNT_inc(filter_state);
3225                             }
3226
3227                             if (tryrsfp == 0) {
3228                                 tryrsfp = PerlIO_open("/dev/null",
3229                                                       PERL_SCRIPT_MODE);
3230                             }
3231                         }
3232                     }
3233
3234                     PUTBACK;
3235                     FREETMPS;
3236                     LEAVE;
3237
3238                     if (tryrsfp) {
3239                         hook_sv = dirsv;
3240                         break;
3241                     }
3242
3243                     filter_has_file = 0;
3244                     if (filter_child_proc) {
3245                         SvREFCNT_dec(filter_child_proc);
3246                         filter_child_proc = 0;
3247                     }
3248                     if (filter_state) {
3249                         SvREFCNT_dec(filter_state);
3250                         filter_state = 0;
3251                     }
3252                     if (filter_sub) {
3253                         SvREFCNT_dec(filter_sub);
3254                         filter_sub = 0;
3255                     }
3256                 }
3257                 else {
3258                     char *dir = SvPVx(dirsv, n_a);
3259 #ifdef MACOS_TRADITIONAL
3260                     char buf[256];
3261                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3262 #else
3263 #ifdef VMS
3264                     char *unixdir;
3265                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3266                         continue;
3267                     sv_setpv(namesv, unixdir);
3268                     sv_catpv(namesv, unixname);
3269 #else
3270                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3271 #endif
3272 #endif
3273                     TAINT_PROPER("require");
3274                     tryname = SvPVX(namesv);
3275 #ifdef MACOS_TRADITIONAL
3276                     {
3277                         /* Convert slashes in the name part, but not the directory part, to colons */
3278                         char * colon;
3279                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3280                             *colon++ = ':';
3281                     }
3282 #endif
3283                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3284                     if (tryrsfp) {
3285                         if (tryname[0] == '.' && tryname[1] == '/')
3286                             tryname += 2;
3287                         break;
3288                     }
3289                 }
3290             }
3291         }
3292     }
3293     SAVECOPFILE_FREE(&PL_compiling);
3294     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3295     SvREFCNT_dec(namesv);
3296     if (!tryrsfp) {
3297         if (PL_op->op_type == OP_REQUIRE) {
3298             char *msgstr = name;
3299             if (namesv) {                       /* did we lookup @INC? */
3300                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3301                 SV *dirmsgsv = NEWSV(0, 0);
3302                 AV *ar = GvAVn(PL_incgv);
3303                 I32 i;
3304                 sv_catpvn(msg, " in @INC", 8);
3305                 if (instr(SvPVX(msg), ".h "))
3306                     sv_catpv(msg, " (change .h to .ph maybe?)");
3307                 if (instr(SvPVX(msg), ".ph "))
3308                     sv_catpv(msg, " (did you run h2ph?)");
3309                 sv_catpv(msg, " (@INC contains:");
3310                 for (i = 0; i <= AvFILL(ar); i++) {
3311                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3312                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3313                     sv_catsv(msg, dirmsgsv);
3314                 }
3315                 sv_catpvn(msg, ")", 1);
3316                 SvREFCNT_dec(dirmsgsv);
3317                 msgstr = SvPV_nolen(msg);
3318             }
3319             DIE(aTHX_ "Can't locate %s", msgstr);
3320         }
3321
3322         RETPUSHUNDEF;
3323     }
3324     else
3325         SETERRNO(0, SS$_NORMAL);
3326
3327     /* Assume success here to prevent recursive requirement. */
3328     len = strlen(name);
3329     /* Check whether a hook in @INC has already filled %INC */
3330     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3331         (void)hv_store(GvHVn(PL_incgv), name, len,
3332                        (hook_sv ? SvREFCNT_inc(hook_sv)
3333                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3334                        0 );
3335     }
3336
3337     ENTER;
3338     SAVETMPS;
3339     lex_start(sv_2mortal(newSVpvn("",0)));
3340     SAVEGENERICSV(PL_rsfp_filters);
3341     PL_rsfp_filters = Nullav;
3342
3343     PL_rsfp = tryrsfp;
3344     SAVEHINTS();
3345     PL_hints = 0;
3346     SAVESPTR(PL_compiling.cop_warnings);
3347     if (PL_dowarn & G_WARN_ALL_ON)
3348         PL_compiling.cop_warnings = pWARN_ALL ;
3349     else if (PL_dowarn & G_WARN_ALL_OFF)
3350         PL_compiling.cop_warnings = pWARN_NONE ;
3351     else
3352         PL_compiling.cop_warnings = pWARN_STD ;
3353     SAVESPTR(PL_compiling.cop_io);
3354     PL_compiling.cop_io = Nullsv;
3355
3356     if (filter_sub || filter_child_proc) {
3357         SV *datasv = filter_add(run_user_filter, Nullsv);
3358         IoLINES(datasv) = filter_has_file;
3359         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3360         IoTOP_GV(datasv) = (GV *)filter_state;
3361         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3362     }
3363
3364     /* switch to eval mode */
3365     push_return(PL_op->op_next);
3366     PUSHBLOCK(cx, CXt_EVAL, SP);
3367     PUSHEVAL(cx, name, Nullgv);
3368
3369     SAVECOPLINE(&PL_compiling);
3370     CopLINE_set(&PL_compiling, 0);
3371
3372     PUTBACK;
3373 #ifdef USE_5005THREADS
3374     MUTEX_LOCK(&PL_eval_mutex);
3375     if (PL_eval_owner && PL_eval_owner != thr)
3376         while (PL_eval_owner)
3377             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3378     PL_eval_owner = thr;
3379     MUTEX_UNLOCK(&PL_eval_mutex);
3380 #endif /* USE_5005THREADS */
3381     return DOCATCH(doeval(gimme, NULL));
3382 }
3383
3384 PP(pp_dofile)
3385 {
3386     return pp_require();
3387 }
3388
3389 PP(pp_entereval)
3390 {
3391     dSP;
3392     register PERL_CONTEXT *cx;
3393     dPOPss;
3394     I32 gimme = GIMME_V, was = PL_sub_generation;
3395     char tbuf[TYPE_DIGITS(long) + 12];
3396     char *tmpbuf = tbuf;
3397     char *safestr;
3398     STRLEN len;
3399     OP *ret;
3400
3401     if (!SvPV(sv,len) || !len)
3402         RETPUSHUNDEF;
3403     TAINT_PROPER("eval");
3404
3405     ENTER;
3406     lex_start(sv);
3407     SAVETMPS;
3408
3409     /* switch to eval mode */
3410
3411     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3412         SV *sv = sv_newmortal();
3413         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3414                        (unsigned long)++PL_evalseq,
3415                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3416         tmpbuf = SvPVX(sv);
3417     }
3418     else
3419         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3420     SAVECOPFILE_FREE(&PL_compiling);
3421     CopFILE_set(&PL_compiling, tmpbuf+2);
3422     SAVECOPLINE(&PL_compiling);
3423     CopLINE_set(&PL_compiling, 1);
3424     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3425        deleting the eval's FILEGV from the stash before gv_check() runs
3426        (i.e. before run-time proper). To work around the coredump that
3427        ensues, we always turn GvMULTI_on for any globals that were
3428        introduced within evals. See force_ident(). GSAR 96-10-12 */
3429     safestr = savepv(tmpbuf);
3430     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3431     SAVEHINTS();
3432     PL_hints = PL_op->op_targ;
3433     SAVESPTR(PL_compiling.cop_warnings);
3434     if (specialWARN(PL_curcop->cop_warnings))
3435         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3436     else {
3437         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3438         SAVEFREESV(PL_compiling.cop_warnings);
3439     }
3440     SAVESPTR(PL_compiling.cop_io);
3441     if (specialCopIO(PL_curcop->cop_io))
3442         PL_compiling.cop_io = PL_curcop->cop_io;
3443     else {
3444         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3445         SAVEFREESV(PL_compiling.cop_io);
3446     }
3447
3448     push_return(PL_op->op_next);
3449     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3450     PUSHEVAL(cx, 0, Nullgv);
3451
3452     /* prepare to compile string */
3453
3454     if (PERLDB_LINE && PL_curstash != PL_debstash)
3455         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3456     PUTBACK;
3457 #ifdef USE_5005THREADS
3458     MUTEX_LOCK(&PL_eval_mutex);
3459     if (PL_eval_owner && PL_eval_owner != thr)
3460         while (PL_eval_owner)
3461             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3462     PL_eval_owner = thr;
3463     MUTEX_UNLOCK(&PL_eval_mutex);
3464 #endif /* USE_5005THREADS */
3465     ret = doeval(gimme, NULL);
3466     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3467         && ret != PL_op->op_next) {     /* Successive compilation. */
3468         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3469     }
3470     return DOCATCH(ret);
3471 }
3472
3473 PP(pp_leaveeval)
3474 {
3475     dSP;
3476     register SV **mark;
3477     SV **newsp;
3478     PMOP *newpm;
3479     I32 gimme;
3480     register PERL_CONTEXT *cx;
3481     OP *retop;
3482     U8 save_flags = PL_op -> op_flags;
3483     I32 optype;
3484
3485     POPBLOCK(cx,newpm);
3486     POPEVAL(cx);
3487     retop = pop_return();
3488
3489     TAINT_NOT;
3490     if (gimme == G_VOID)
3491         MARK = newsp;
3492     else if (gimme == G_SCALAR) {
3493         MARK = newsp + 1;
3494         if (MARK <= SP) {
3495             if (SvFLAGS(TOPs) & SVs_TEMP)
3496                 *MARK = TOPs;
3497             else
3498                 *MARK = sv_mortalcopy(TOPs);
3499         }
3500         else {
3501             MEXTEND(mark,0);
3502             *MARK = &PL_sv_undef;
3503         }
3504         SP = MARK;
3505     }
3506     else {
3507         /* in case LEAVE wipes old return values */
3508         for (mark = newsp + 1; mark <= SP; mark++) {
3509             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3510                 *mark = sv_mortalcopy(*mark);
3511                 TAINT_NOT;      /* Each item is independent */
3512             }
3513         }
3514     }
3515     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3516
3517 #ifdef DEBUGGING
3518     assert(CvDEPTH(PL_compcv) == 1);
3519 #endif
3520     CvDEPTH(PL_compcv) = 0;
3521     lex_end();
3522
3523     if (optype == OP_REQUIRE &&
3524         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3525     {
3526         /* Unassume the success we assumed earlier. */
3527         SV *nsv = cx->blk_eval.old_namesv;
3528         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3529         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3530         /* die_where() did LEAVE, or we won't be here */
3531     }
3532     else {
3533         LEAVE;
3534         if (!(save_flags & OPf_SPECIAL))
3535             sv_setpv(ERRSV,"");
3536     }
3537
3538     RETURNOP(retop);
3539 }
3540
3541 PP(pp_entertry)
3542 {
3543     dSP;
3544     register PERL_CONTEXT *cx;
3545     I32 gimme = GIMME_V;
3546
3547     ENTER;
3548     SAVETMPS;
3549
3550     push_return(cLOGOP->op_other->op_next);
3551     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3552     PUSHEVAL(cx, 0, 0);
3553
3554     PL_in_eval = EVAL_INEVAL;
3555     sv_setpv(ERRSV,"");
3556     PUTBACK;
3557     return DOCATCH(PL_op->op_next);
3558 }
3559
3560 PP(pp_leavetry)
3561 {
3562     dSP;
3563     register SV **mark;
3564     SV **newsp;
3565     PMOP *newpm;
3566     I32 gimme;
3567     register PERL_CONTEXT *cx;
3568     I32 optype;
3569
3570     POPBLOCK(cx,newpm);
3571     POPEVAL(cx);
3572     pop_return();
3573
3574     TAINT_NOT;
3575     if (gimme == G_VOID)
3576         SP = newsp;
3577     else if (gimme == G_SCALAR) {
3578         MARK = newsp + 1;
3579         if (MARK <= SP) {
3580             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3581                 *MARK = TOPs;
3582             else
3583                 *MARK = sv_mortalcopy(TOPs);
3584         }
3585         else {
3586             MEXTEND(mark,0);
3587             *MARK = &PL_sv_undef;
3588         }
3589         SP = MARK;
3590     }
3591     else {
3592         /* in case LEAVE wipes old return values */
3593         for (mark = newsp + 1; mark <= SP; mark++) {
3594             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3595                 *mark = sv_mortalcopy(*mark);
3596                 TAINT_NOT;      /* Each item is independent */
3597             }
3598         }
3599     }
3600     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3601
3602     LEAVE;
3603     sv_setpv(ERRSV,"");
3604     RETURN;
3605 }
3606
3607 STATIC void
3608 S_doparseform(pTHX_ SV *sv)
3609 {
3610     STRLEN len;
3611     register char *s = SvPV_force(sv, len);
3612     register char *send = s + len;
3613     register char *base = Nullch;
3614     register I32 skipspaces = 0;
3615     bool noblank   = FALSE;
3616     bool repeat    = FALSE;
3617     bool postspace = FALSE;
3618     U16 *fops;
3619     register U16 *fpc;
3620     U16 *linepc = 0;
3621     register I32 arg;
3622     bool ischop;
3623
3624     if (len == 0)
3625         Perl_croak(aTHX_ "Null picture in formline");
3626
3627     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3628     fpc = fops;
3629
3630     if (s < send) {
3631         linepc = fpc;
3632         *fpc++ = FF_LINEMARK;
3633         noblank = repeat = FALSE;
3634         base = s;
3635     }
3636
3637     while (s <= send) {
3638         switch (*s++) {
3639         default:
3640             skipspaces = 0;
3641             continue;
3642
3643         case '~':
3644             if (*s == '~') {
3645                 repeat = TRUE;
3646                 *s = ' ';
3647             }
3648             noblank = TRUE;
3649             s[-1] = ' ';
3650             /* FALL THROUGH */
3651         case ' ': case '\t':
3652             skipspaces++;
3653             continue;
3654
3655         case '\n': case 0:
3656             arg = s - base;
3657             skipspaces++;
3658             arg -= skipspaces;
3659             if (arg) {
3660                 if (postspace)
3661                     *fpc++ = FF_SPACE;
3662                 *fpc++ = FF_LITERAL;
3663                 *fpc++ = arg;
3664             }
3665             postspace = FALSE;
3666             if (s <= send)
3667                 skipspaces--;
3668             if (skipspaces) {
3669                 *fpc++ = FF_SKIP;
3670                 *fpc++ = skipspaces;
3671             }
3672             skipspaces = 0;
3673             if (s <= send)
3674                 *fpc++ = FF_NEWLINE;
3675             if (noblank) {
3676                 *fpc++ = FF_BLANK;
3677                 if (repeat)
3678                     arg = fpc - linepc + 1;
3679                 else
3680                     arg = 0;
3681                 *fpc++ = arg;
3682             }
3683             if (s < send) {
3684                 linepc = fpc;
3685                 *fpc++ = FF_LINEMARK;
3686                 noblank = repeat = FALSE;
3687                 base = s;
3688             }
3689             else
3690                 s++;
3691             continue;
3692
3693         case '@':
3694         case '^':
3695             ischop = s[-1] == '^';
3696
3697             if (postspace) {
3698                 *fpc++ = FF_SPACE;
3699                 postspace = FALSE;
3700             }
3701             arg = (s - base) - 1;
3702             if (arg) {
3703                 *fpc++ = FF_LITERAL;
3704                 *fpc++ = arg;
3705             }
3706
3707             base = s - 1;
3708             *fpc++ = FF_FETCH;
3709             if (*s == '*') {
3710                 s++;
3711                 *fpc++ = 0;
3712                 *fpc++ = FF_LINEGLOB;
3713             }
3714             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3715                 arg = ischop ? 512 : 0;
3716                 base = s - 1;
3717                 while (*s == '#')
3718                     s++;
3719                 if (*s == '.') {
3720                     char *f;
3721                     s++;
3722                     f = s;
3723                     while (*s == '#')
3724                         s++;
3725                     arg |= 256 + (s - f);
3726                 }
3727                 *fpc++ = s - base;              /* fieldsize for FETCH */
3728                 *fpc++ = FF_DECIMAL;
3729                 *fpc++ = arg;
3730             }
3731             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3732                 arg = ischop ? 512 : 0;
3733                 base = s - 1;
3734                 s++;                                /* skip the '0' first */
3735                 while (*s == '#')
3736                     s++;
3737                 if (*s == '.') {
3738                     char *f;
3739                     s++;
3740                     f = s;
3741                     while (*s == '#')
3742                         s++;
3743                     arg |= 256 + (s - f);
3744                 }
3745                 *fpc++ = s - base;                /* fieldsize for FETCH */
3746                 *fpc++ = FF_0DECIMAL;
3747                 *fpc++ = arg;
3748             }
3749             else {
3750                 I32 prespace = 0;
3751                 bool ismore = FALSE;
3752
3753                 if (*s == '>') {
3754                     while (*++s == '>') ;
3755                     prespace = FF_SPACE;
3756                 }
3757                 else if (*s == '|') {
3758                     while (*++s == '|') ;
3759                     prespace = FF_HALFSPACE;
3760                     postspace = TRUE;
3761                 }
3762                 else {
3763                     if (*s == '<')
3764                         while (*++s == '<') ;
3765                     postspace = TRUE;
3766                 }
3767                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3768                     s += 3;
3769                     ismore = TRUE;
3770                 }
3771                 *fpc++ = s - base;              /* fieldsize for FETCH */
3772
3773                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3774
3775                 if (prespace)
3776                     *fpc++ = prespace;
3777                 *fpc++ = FF_ITEM;
3778                 if (ismore)
3779                     *fpc++ = FF_MORE;
3780                 if (ischop)
3781                     *fpc++ = FF_CHOP;
3782             }
3783             base = s;
3784             skipspaces = 0;
3785             continue;
3786         }
3787     }
3788     *fpc++ = FF_END;
3789
3790     arg = fpc - fops;
3791     { /* need to jump to the next word */
3792         int z;
3793         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3794         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3795         s = SvPVX(sv) + SvCUR(sv) + z;
3796     }
3797     Copy(fops, s, arg, U16);
3798     Safefree(fops);
3799     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3800     SvCOMPILED_on(sv);
3801 }
3802
3803 /*
3804  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3805  *
3806  * The original code was written in conjunction with BSD Computer Software
3807  * Research Group at University of California, Berkeley.
3808  *
3809  * See also: "Optimistic Merge Sort" (SODA '92)
3810  *
3811  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3812  *
3813  * The code can be distributed under the same terms as Perl itself.
3814  *
3815  */
3816
3817 #ifdef  TESTHARNESS
3818 #include <sys/types.h>
3819 typedef void SV;
3820 #define pTHX_
3821 #define STATIC
3822 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3823 #define Safefree(VAR) free(VAR)
3824 typedef int  (*SVCOMPARE_t) (pTHX_ SV*, SV*);
3825 #endif  /* TESTHARNESS */
3826
3827 typedef char * aptr;            /* pointer for arithmetic on sizes */
3828 typedef SV * gptr;              /* pointers in our lists */
3829
3830 /* Binary merge internal sort, with a few special mods
3831 ** for the special perl environment it now finds itself in.
3832 **
3833 ** Things that were once options have been hotwired
3834 ** to values suitable for this use.  In particular, we'll always
3835 ** initialize looking for natural runs, we'll always produce stable
3836 ** output, and we'll always do Peter McIlroy's binary merge.
3837 */
3838
3839 /* Pointer types for arithmetic and storage and convenience casts */
3840
3841 #define APTR(P) ((aptr)(P))
3842 #define GPTP(P) ((gptr *)(P))
3843 #define GPPP(P) ((gptr **)(P))
3844
3845
3846 /* byte offset from pointer P to (larger) pointer Q */
3847 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3848
3849 #define PSIZE sizeof(gptr)
3850
3851 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3852
3853 #ifdef  PSHIFT
3854 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
3855 #define PNBYTE(N)       ((N) << (PSHIFT))
3856 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
3857 #else
3858 /* Leave optimization to compiler */
3859 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
3860 #define PNBYTE(N)       ((N) * (PSIZE))
3861 #define PINDEX(P, N)    (GPTP(P) + (N))
3862 #endif
3863
3864 /* Pointer into other corresponding to pointer into this */
3865 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3866
3867 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3868
3869
3870 /* Runs are identified by a pointer in the auxilliary list.
3871 ** The pointer is at the start of the list,
3872 ** and it points to the start of the next list.
3873 ** NEXT is used as an lvalue, too.
3874 */
3875
3876 #define NEXT(P)         (*GPPP(P))
3877
3878
3879 /* PTHRESH is the minimum number of pairs with the same sense to justify
3880 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
3881 ** not just elements, so PTHRESH == 8 means a run of 16.
3882 */
3883
3884 #define PTHRESH (8)
3885
3886 /* RTHRESH is the number of elements in a run that must compare low
3887 ** to the low element from the opposing run before we justify
3888 ** doing a binary rampup instead of single stepping.
3889 ** In random input, N in a row low should only happen with
3890 ** probability 2^(1-N), so we can risk that we are dealing
3891 ** with orderly input without paying much when we aren't.
3892 */
3893
3894 #define RTHRESH (6)
3895
3896
3897 /*
3898 ** Overview of algorithm and variables.
3899 ** The array of elements at list1 will be organized into runs of length 2,
3900 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
3901 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3902 **
3903 ** Unless otherwise specified, pair pointers address the first of two elements.
3904 **
3905 ** b and b+1 are a pair that compare with sense ``sense''.
3906 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3907 **
3908 ** p2 parallels b in the list2 array, where runs are defined by
3909 ** a pointer chain.
3910 **
3911 ** t represents the ``top'' of the adjacent pairs that might extend
3912 ** the run beginning at b.  Usually, t addresses a pair
3913 ** that compares with opposite sense from (b,b+1).
3914 ** However, it may also address a singleton element at the end of list1,
3915 ** or it may be equal to ``last'', the first element beyond list1.
3916 **
3917 ** r addresses the Nth pair following b.  If this would be beyond t,
3918 ** we back it off to t.  Only when r is less than t do we consider the
3919 ** run long enough to consider checking.
3920 **
3921 ** q addresses a pair such that the pairs at b through q already form a run.
3922 ** Often, q will equal b, indicating we only are sure of the pair itself.
3923 ** However, a search on the previous cycle may have revealed a longer run,
3924 ** so q may be greater than b.
3925 **
3926 ** p is used to work back from a candidate r, trying to reach q,
3927 ** which would mean b through r would be a run.  If we discover such a run,
3928 ** we start q at r and try to push it further towards t.
3929 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3930 ** In any event, after the check (if any), we have two main cases.
3931 **
3932 ** 1) Short run.  b <= q < p <= r <= t.
3933 **      b through q is a run (perhaps trivial)
3934 **      q through p are uninteresting pairs
3935 **      p through r is a run
3936 **
3937 ** 2) Long run.  b < r <= q < t.
3938 **      b through q is a run (of length >= 2 * PTHRESH)
3939 **
3940 ** Note that degenerate cases are not only possible, but likely.
3941 ** For example, if the pair following b compares with opposite sense,
3942 ** then b == q < p == r == t.
3943 */
3944
3945
3946 static void
3947 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3948 {
3949     int sense;
3950     register gptr *b, *p, *q, *t, *p2;
3951     register gptr c, *last, *r;
3952     gptr *savep;
3953
3954     b = list1;
3955     last = PINDEX(b, nmemb);
3956     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3957     for (p2 = list2; b < last; ) {
3958         /* We just started, or just reversed sense.
3959         ** Set t at end of pairs with the prevailing sense.
3960         */
3961         for (p = b+2, t = p; ++p < last; t = ++p) {
3962             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3963         }
3964         q = b;
3965         /* Having laid out the playing field, look for long runs */
3966         do {
3967             p = r = b + (2 * PTHRESH);
3968             if (r >= t) p = r = t;      /* too short to care about */
3969             else {
3970                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3971                        ((p -= 2) > q));
3972                 if (p <= q) {
3973                     /* b through r is a (long) run.
3974                     ** Extend it as far as possible.
3975                     */
3976                     p = q = r;
3977                     while (((p += 2) < t) &&
3978                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3979                     r = p = q + 2;      /* no simple pairs, no after-run */
3980                 }
3981             }
3982             if (q > b) {                /* run of greater than 2 at b */
3983                 savep = p;
3984                 p = q += 2;
3985                 /* pick up singleton, if possible */
3986                 if ((p == t) &&
3987                     ((t + 1) == last) &&
3988                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3989                     savep = r = p = q = last;
3990                 p2 = NEXT(p2) = p2 + (p - b);
3991                 if (sense) while (b < --p) {
3992                     c = *b;
3993                     *b++ = *p;
3994                     *p = c;
3995                 }
3996                 p = savep;
3997             }
3998             while (q < p) {             /* simple pairs */
3999                 p2 = NEXT(p2) = p2 + 2;
4000                 if (sense) {
4001                     c = *q++;
4002                     *(q-1) = *q;
4003                     *q++ = c;
4004                 } else q += 2;
4005             }
4006             if (((b = p) == t) && ((t+1) == last)) {
4007                 NEXT(p2) = p2 + 1;
4008                 b++;
4009             }
4010             q = r;
4011         } while (b < t);
4012         sense = !sense;
4013     }
4014     return;
4015 }
4016
4017
4018 /* Overview of bmerge variables:
4019 **
4020 ** list1 and list2 address the main and auxiliary arrays.
4021 ** They swap identities after each merge pass.
4022 ** Base points to the original list1, so we can tell if
4023 ** the pointers ended up where they belonged (or must be copied).
4024 **
4025 ** When we are merging two lists, f1 and f2 are the next elements
4026 ** on the respective lists.  l1 and l2 mark the end of the lists.
4027 ** tp2 is the current location in the merged list.
4028 **
4029 ** p1 records where f1 started.
4030 ** After the merge, a new descriptor is built there.
4031 **
4032 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4033 ** It is used to identify and delimit the runs.
4034 **
4035 ** In the heat of determining where q, the greater of the f1/f2 elements,
4036 ** belongs in the other list, b, t and p, represent bottom, top and probe
4037 ** locations, respectively, in the other list.
4038 ** They make convenient temporary pointers in other places.
4039 */
4040
4041 /*
4042 =for apidoc sortsv
4043
4044 Sort an array. Here is an example:
4045
4046     sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
4047
4048 =cut
4049 */
4050
4051 void
4052 Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4053 {
4054     int i, run;
4055     int sense;
4056     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4057     gptr *aux, *list2, *p2, *last;
4058     gptr *base = list1;
4059     gptr *p1;
4060
4061     if (nmemb <= 1) return;     /* sorted trivially */
4062     New(799,list2,nmemb,gptr);  /* allocate auxilliary array */
4063     aux = list2;
4064     dynprep(aTHX_ list1, list2, nmemb, cmp);
4065     last = PINDEX(list2, nmemb);
4066     while (NEXT(list2) != last) {
4067         /* More than one run remains.  Do some merging to reduce runs. */
4068         l2 = p1 = list1;
4069         for (tp2 = p2 = list2; p2 != last;) {
4070             /* The new first run begins where the old second list ended.
4071             ** Use the p2 ``parallel'' pointer to identify the end of the run.
4072             */
4073             f1 = l2;
4074             t = NEXT(p2);
4075             f2 = l1 = POTHER(t, list2, list1);
4076             if (t != last) t = NEXT(t);
4077             l2 = POTHER(t, list2, list1);
4078             p2 = t;
4079             while (f1 < l1 && f2 < l2) {
4080                 /* If head 1 is larger than head 2, find ALL the elements
4081                 ** in list 2 strictly less than head1, write them all,
4082                 ** then head 1.  Then compare the new heads, and repeat,
4083                 ** until one or both lists are exhausted.
4084                 **
4085                 ** In all comparisons (after establishing
4086                 ** which head to merge) the item to merge
4087                 ** (at pointer q) is the first operand of
4088                 ** the comparison.  When we want to know
4089                 ** if ``q is strictly less than the other'',
4090                 ** we can't just do
4091                 **    cmp(q, other) < 0
4092                 ** because stability demands that we treat equality
4093                 ** as high when q comes from l2, and as low when
4094                 ** q was from l1.  So we ask the question by doing
4095                 **    cmp(q, other) <= sense
4096                 ** and make sense == 0 when equality should look low,
4097                 ** and -1 when equality should look high.
4098                 */
4099
4100
4101                 if (cmp(aTHX_ *f1, *f2) <= 0) {
4102                     q = f2; b = f1; t = l1;
4103                     sense = -1;
4104                 } else {
4105                     q = f1; b = f2; t = l2;
4106                     sense = 0;
4107                 }
4108
4109
4110                 /* ramp up
4111                 **
4112                 ** Leave t at something strictly
4113                 ** greater than q (or at the end of the list),
4114                 ** and b at something strictly less than q.
4115                 */
4116                 for (i = 1, run = 0 ;;) {
4117                     if ((p = PINDEX(b, i)) >= t) {
4118                         /* off the end */
4119                         if (((p = PINDEX(t, -1)) > b) &&
4120                             (cmp(aTHX_ *q, *p) <= sense))
4121                              t = p;
4122                         else b = p;
4123                         break;
4124                     } else if (cmp(aTHX_ *q, *p) <= sense) {
4125                         t = p;
4126                         break;
4127                     } else b = p;
4128                     if (++run >= RTHRESH) i += i;
4129                 }
4130
4131
4132                 /* q is known to follow b and must be inserted before t.
4133                 ** Increment b, so the range of possibilities is [b,t).
4134                 ** Round binary split down, to favor early appearance.
4135                 ** Adjust b and t until q belongs just before t.
4136                 */
4137
4138                 b++;
4139                 while (b < t) {
4140                     p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4141                     if (cmp(aTHX_ *q, *p) <= sense) {
4142                         t = p;
4143                     } else b = p + 1;
4144                 }
4145
4146
4147                 /* Copy all the strictly low elements */
4148
4149                 if (q == f1) {
4150                     FROMTOUPTO(f2, tp2, t);
4151                     *tp2++ = *f1++;
4152                 } else {
4153                     FROMTOUPTO(f1, tp2, t);
4154                     *tp2++ = *f2++;
4155                 }
4156             }
4157
4158
4159             /* Run out remaining list */
4160             if (f1 == l1) {
4161                    if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4162             } else              FROMTOUPTO(f1, tp2, l1);
4163             p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4164         }
4165         t = list1;
4166         list1 = list2;
4167         list2 = t;
4168         last = PINDEX(list2, nmemb);
4169     }
4170     if (base == list2) {
4171         last = PINDEX(list1, nmemb);
4172         FROMTOUPTO(list1, list2, last);
4173     }
4174     Safefree(aux);
4175     return;
4176 }
4177
4178 static I32
4179 sortcv(pTHX_ SV *a, SV *b)
4180 {
4181     I32 oldsaveix = PL_savestack_ix;
4182     I32 oldscopeix = PL_scopestack_ix;
4183     I32 result;
4184     GvSV(PL_firstgv) = a;
4185     GvSV(PL_secondgv) = b;
4186     PL_stack_sp = PL_stack_base;
4187     PL_op = PL_sortcop;
4188     CALLRUNOPS(aTHX);
4189     if (PL_stack_sp != PL_stack_base + 1)
4190         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4191     if (!SvNIOKp(*PL_stack_sp))
4192         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4193     result = SvIV(*PL_stack_sp);
4194     while (PL_scopestack_ix > oldscopeix) {
4195         LEAVE;
4196     }
4197     leave_scope(oldsaveix);
4198     return result;
4199 }
4200
4201 static I32
4202 sortcv_stacked(pTHX_ SV *a, SV *b)
4203 {
4204     I32 oldsaveix = PL_savestack_ix;
4205     I32 oldscopeix = PL_scopestack_ix;
4206     I32 result;
4207     AV *av;
4208
4209 #ifdef USE_5005THREADS
4210     av = (AV*)PL_curpad[0];
4211 #else
4212     av = GvAV(PL_defgv);
4213 #endif
4214
4215     if (AvMAX(av) < 1) {
4216         SV** ary = AvALLOC(av);
4217         if (AvARRAY(av) != ary) {
4218             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4219             SvPVX(av) = (char*)ary;
4220         }
4221         if (AvMAX(av) < 1) {
4222             AvMAX(av) = 1;
4223             Renew(ary,2,SV*);
4224             SvPVX(av) = (char*)ary;
4225         }
4226     }
4227     AvFILLp(av) = 1;
4228
4229     AvARRAY(av)[0] = a;
4230     AvARRAY(av)[1] = b;
4231     PL_stack_sp = PL_stack_base;
4232     PL_op = PL_sortcop;
4233     CALLRUNOPS(aTHX);
4234     if (PL_stack_sp != PL_stack_base + 1)
4235         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4236     if (!SvNIOKp(*PL_stack_sp))
4237         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4238     result = SvIV(*PL_stack_sp);
4239     while (PL_scopestack_ix > oldscopeix) {
4240         LEAVE;
4241     }
4242     leave_scope(oldsaveix);
4243     return result;
4244 }
4245
4246 static I32
4247 sortcv_xsub(pTHX_ SV *a, SV *b)
4248 {
4249     dSP;
4250     I32 oldsaveix = PL_savestack_ix;
4251     I32 oldscopeix = PL_scopestack_ix;
4252     I32 result;
4253     CV *cv=(CV*)PL_sortcop;
4254
4255     SP = PL_stack_base;
4256     PUSHMARK(SP);
4257     EXTEND(SP, 2);
4258     *++SP = a;
4259     *++SP = b;
4260     PUTBACK;
4261     (void)(*CvXSUB(cv))(aTHX_ cv);
4262     if (PL_stack_sp != PL_stack_base + 1)
4263         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4264     if (!SvNIOKp(*PL_stack_sp))
4265         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4266     result = SvIV(*PL_stack_sp);
4267     while (PL_scopestack_ix > oldscopeix) {
4268         LEAVE;
4269     }
4270     leave_scope(oldsaveix);
4271     return result;
4272 }
4273
4274
4275 static I32
4276 sv_ncmp(pTHX_ SV *a, SV *b)
4277 {
4278     NV nv1 = SvNV(a);
4279     NV nv2 = SvNV(b);
4280     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4281 }
4282
4283 static I32
4284 sv_i_ncmp(pTHX_ SV *a, SV *b)
4285 {
4286     IV iv1 = SvIV(a);
4287     IV iv2 = SvIV(b);
4288     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4289 }
4290 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4291           *svp = Nullsv;                                \
4292           if (PL_amagic_generation) { \
4293             if (SvAMAGIC(left)||SvAMAGIC(right))\
4294                 *svp = amagic_call(left, \
4295                                    right, \
4296                                    CAT2(meth,_amg), \
4297                                    0); \
4298           } \
4299         } STMT_END
4300
4301 static I32
4302 amagic_ncmp(pTHX_ register SV *a, register SV *b)
4303 {
4304     SV *tmpsv;
4305     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4306     if (tmpsv) {
4307         NV d;
4308
4309         if (SvIOK(tmpsv)) {
4310             I32 i = SvIVX(tmpsv);
4311             if (i > 0)
4312                return 1;
4313             return i? -1 : 0;
4314         }
4315         d = SvNV(tmpsv);
4316         if (d > 0)
4317            return 1;
4318         return d? -1 : 0;
4319      }
4320      return sv_ncmp(aTHX_ a, b);
4321 }
4322
4323 static I32
4324 amagic_i_ncmp(pTHX_ register SV *a, register SV *b)
4325 {
4326     SV *tmpsv;
4327     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4328     if (tmpsv) {
4329         NV d;
4330
4331         if (SvIOK(tmpsv)) {
4332             I32 i = SvIVX(tmpsv);
4333             if (i > 0)
4334                return 1;
4335             return i? -1 : 0;
4336         }
4337         d = SvNV(tmpsv);
4338         if (d > 0)
4339            return 1;
4340         return d? -1 : 0;
4341     }
4342     return sv_i_ncmp(aTHX_ a, b);
4343 }
4344
4345 static I32
4346 amagic_cmp(pTHX_ register SV *str1, register SV *str2)
4347 {
4348     SV *tmpsv;
4349     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4350     if (tmpsv) {
4351         NV d;
4352
4353         if (SvIOK(tmpsv)) {
4354             I32 i = SvIVX(tmpsv);
4355             if (i > 0)
4356                return 1;
4357             return i? -1 : 0;
4358         }
4359         d = SvNV(tmpsv);
4360         if (d > 0)
4361            return 1;
4362         return d? -1 : 0;
4363     }
4364     return sv_cmp(str1, str2);
4365 }
4366
4367 static I32
4368 amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2)
4369 {
4370     SV *tmpsv;
4371     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4372     if (tmpsv) {
4373         NV d;
4374
4375         if (SvIOK(tmpsv)) {
4376             I32 i = SvIVX(tmpsv);
4377             if (i > 0)
4378                return 1;
4379             return i? -1 : 0;
4380         }
4381         d = SvNV(tmpsv);
4382         if (d > 0)
4383            return 1;
4384         return d? -1 : 0;
4385     }
4386     return sv_cmp_locale(str1, str2);
4387 }
4388
4389 static I32
4390 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4391 {
4392     SV *datasv = FILTER_DATA(idx);
4393     int filter_has_file = IoLINES(datasv);
4394     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4395     SV *filter_state = (SV *)IoTOP_GV(datasv);
4396     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4397     int len = 0;
4398
4399     /* I was having segfault trouble under Linux 2.2.5 after a
4400        parse error occured.  (Had to hack around it with a test
4401        for PL_error_count == 0.)  Solaris doesn't segfault --
4402        not sure where the trouble is yet.  XXX */
4403
4404     if (filter_has_file) {
4405         len = FILTER_READ(idx+1, buf_sv, maxlen);
4406     }
4407
4408     if (filter_sub && len >= 0) {
4409         dSP;
4410         int count;
4411
4412         ENTER;
4413         SAVE_DEFSV;
4414         SAVETMPS;
4415         EXTEND(SP, 2);
4416
4417         DEFSV = buf_sv;
4418         PUSHMARK(SP);
4419         PUSHs(sv_2mortal(newSViv(maxlen)));
4420         if (filter_state) {
4421             PUSHs(filter_state);
4422         }
4423         PUTBACK;
4424         count = call_sv(filter_sub, G_SCALAR);
4425         SPAGAIN;
4426
4427         if (count > 0) {
4428             SV *out = POPs;
4429             if (SvOK(out)) {
4430                 len = SvIV(out);
4431             }
4432         }
4433
4434         PUTBACK;
4435         FREETMPS;
4436         LEAVE;
4437     }
4438
4439     if (len <= 0) {
4440         IoLINES(datasv) = 0;
4441         if (filter_child_proc) {
4442             SvREFCNT_dec(filter_child_proc);
4443             IoFMT_GV(datasv) = Nullgv;
4444         }
4445         if (filter_state) {
4446             SvREFCNT_dec(filter_state);
4447             IoTOP_GV(datasv) = Nullgv;
4448         }
4449         if (filter_sub) {
4450             SvREFCNT_dec(filter_sub);
4451             IoBOTTOM_GV(datasv) = Nullgv;
4452         }
4453         filter_del(run_user_filter);
4454     }
4455
4456     return len;
4457 }