pp_ctl.c

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