pp_ctl.c

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