pp_ctl.c

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