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