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