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