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