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