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