pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Now far ahead the Road has gone,
  12  * And I must follow, if I can,
  13  * Pursuing it with eager feet,
  14  * Until it joins some larger way
  15  * Where many paths and errands meet.
  16  * And whither then?  I cannot say.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_CTL_C
  21 #include "perl.h"
  22
  23 #ifndef WORD_ALIGN
  24 #define WORD_ALIGN sizeof(U16)
  25 #endif
  26
  27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  28
  29 static I32 sortcv(pTHXo_ SV *a, SV *b);
  30 static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
  31 static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
  32 static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
  33 static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
  34 static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
  35 static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
  36 static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
  37 static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
  38 static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
  39
  40 #ifdef PERL_OBJECT
  41 static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
  42 static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
  43 #else
  44 #define sv_cmp_static Perl_sv_cmp
  45 #define sv_cmp_locale_static Perl_sv_cmp_locale
  46 #endif
  47
  48 PP(pp_wantarray)
  49 {
  50     dSP;
  51     I32 cxix;
  52     EXTEND(SP, 1);
  53
  54     cxix = dopoptosub(cxstack_ix);
  55     if (cxix < 0)
  56         RETPUSHUNDEF;
  57
  58     switch (cxstack[cxix].blk_gimme) {
  59     case G_ARRAY:
  60         RETPUSHYES;
  61     case G_SCALAR:
  62         RETPUSHNO;
  63     default:
  64         RETPUSHUNDEF;
  65     }
  66 }
  67
  68 PP(pp_regcmaybe)
  69 {
  70     return NORMAL;
  71 }
  72
  73 PP(pp_regcreset)
  74 {
  75     /* XXXX Should store the old value to allow for tie/overload - and
  76        restore in regcomp, where marked with XXXX. */
  77     PL_reginterp_cnt = 0;
  78     return NORMAL;
  79 }
  80
  81 PP(pp_regcomp)
  82 {
  83     dSP;
  84     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  85     register char *t;
  86     SV *tmpstr;
  87     STRLEN len;
  88     MAGIC *mg = Null(MAGIC*);
  89
  90     tmpstr = POPs;
  91
  92     /* prevent recompiling under /o and ithreads. */
  93 #if defined(USE_ITHREADS) || defined(USE_THREADS)
  94     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
  95          RETURN;
  96 #endif
  97
  98     if (SvROK(tmpstr)) {
  99         SV *sv = SvRV(tmpstr);
 100         if(SvMAGICAL(sv))
 101             mg = mg_find(sv, PERL_MAGIC_qr);
 102     }
 103     if (mg) {
 104         regexp *re = (regexp *)mg->mg_obj;
 105         ReREFCNT_dec(PM_GETRE(pm));
 106         PM_SETRE(pm, ReREFCNT_inc(re));
 107     }
 108     else {
 109         t = SvPV(tmpstr, len);
 110
 111         /* Check against the last compiled regexp. */
 112         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
 113             PM_GETRE(pm)->prelen != len ||
 114             memNE(PM_GETRE(pm)->precomp, t, len))
 115         {
 116             if (PM_GETRE(pm)) {
 117                 ReREFCNT_dec(PM_GETRE(pm));
 118                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
 119             }
 120             if (PL_op->op_flags & OPf_SPECIAL)
 121                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 122
 123             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 124             if (DO_UTF8(tmpstr))
 125                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 126             else {
 127                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 128                 if (pm->op_pmdynflags & PMdf_UTF8)
 129                     t = (char*)bytes_to_utf8((U8*)t, &len);
 130             }
 131             PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
 132             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
 133                 Safefree(t);
 134             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 135                                            inside tie/overload accessors.  */
 136         }
 137     }
 138
 139 #ifndef INCOMPLETE_TAINTS
 140     if (PL_tainting) {
 141         if (PL_tainted)
 142             pm->op_pmdynflags |= PMdf_TAINTED;
 143         else
 144             pm->op_pmdynflags &= ~PMdf_TAINTED;
 145     }
 146 #endif
 147
 148     if (!PM_GETRE(pm)->prelen && PL_curpm)
 149         pm = PL_curpm;
 150     else 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_THREADS)
 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_THREADS */
 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_THREADS
 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_THREADS
1020                 cx->blk_sub.savearray = GvAV(PL_defgv);
1021                 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
1022 #endif /* USE_THREADS */
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                         PL_op_name[PL_op->op_type]);
1199             break;
1200         case CXt_SUB:
1201             if (ckWARN(WARN_EXITING))
1202                 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1203                         PL_op_name[PL_op->op_type]);
1204             break;
1205         case CXt_FORMAT:
1206             if (ckWARN(WARN_EXITING))
1207                 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1208                         PL_op_name[PL_op->op_type]);
1209             break;
1210         case CXt_EVAL:
1211             if (ckWARN(WARN_EXITING))
1212                 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1213                         PL_op_name[PL_op->op_type]);
1214             break;
1215         case CXt_NULL:
1216             if (ckWARN(WARN_EXITING))
1217                 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1218                         PL_op_name[PL_op->op_type]);
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                         PL_op_name[PL_op->op_type]);
1334             break;
1335         case CXt_SUB:
1336             if (ckWARN(WARN_EXITING))
1337                 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1338                         PL_op_name[PL_op->op_type]);
1339             break;
1340         case CXt_FORMAT:
1341             if (ckWARN(WARN_EXITING))
1342                 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1343                         PL_op_name[PL_op->op_type]);
1344             break;
1345         case CXt_EVAL:
1346             if (ckWARN(WARN_EXITING))
1347                 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1348                         PL_op_name[PL_op->op_type]);
1349             break;
1350         case CXt_NULL:
1351             if (ckWARN(WARN_EXITING))
1352                 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1353                         PL_op_name[PL_op->op_type]);
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     EXTEND(SP, 10);
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                 RETPUSHUNDEF;
1565             RETURN;
1566         }
1567         if (PL_DBsub && cxix >= 0 &&
1568                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1569             count++;
1570         if (!count--)
1571             break;
1572         cxix = dopoptosub_at(ccstack, cxix - 1);
1573     }
1574
1575     cx = &ccstack[cxix];
1576     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1577         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1578         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1579            field below is defined for any cx. */
1580         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1581             cx = &ccstack[dbcxix];
1582     }
1583
1584     stashname = CopSTASHPV(cx->blk_oldcop);
1585     if (GIMME != G_ARRAY) {
1586         if (!stashname)
1587             PUSHs(&PL_sv_undef);
1588         else {
1589             dTARGET;
1590             sv_setpv(TARG, stashname);
1591             PUSHs(TARG);
1592         }
1593         RETURN;
1594     }
1595
1596     if (!stashname)
1597         PUSHs(&PL_sv_undef);
1598     else
1599         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1600     PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1601     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1602     if (!MAXARG)
1603         RETURN;
1604     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1605         /* So is ccstack[dbcxix]. */
1606         sv = NEWSV(49, 0);
1607         gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1608         PUSHs(sv_2mortal(sv));
1609         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1610     }
1611     else {
1612         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1613         PUSHs(sv_2mortal(newSViv(0)));
1614     }
1615     gimme = (I32)cx->blk_gimme;
1616     if (gimme == G_VOID)
1617         PUSHs(&PL_sv_undef);
1618     else
1619         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1620     if (CxTYPE(cx) == CXt_EVAL) {
1621         /* eval STRING */
1622         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1623             PUSHs(cx->blk_eval.cur_text);
1624             PUSHs(&PL_sv_no);
1625         }
1626         /* require */
1627         else if (cx->blk_eval.old_namesv) {
1628             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1629             PUSHs(&PL_sv_yes);
1630         }
1631         /* eval BLOCK (try blocks have old_namesv == 0) */
1632         else {
1633             PUSHs(&PL_sv_undef);
1634             PUSHs(&PL_sv_undef);
1635         }
1636     }
1637     else {
1638         PUSHs(&PL_sv_undef);
1639         PUSHs(&PL_sv_undef);
1640     }
1641     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1642         && CopSTASH_eq(PL_curcop, PL_debstash))
1643     {
1644         AV *ary = cx->blk_sub.argarray;
1645         int off = AvARRAY(ary) - AvALLOC(ary);
1646
1647         if (!PL_dbargs) {
1648             GV* tmpgv;
1649             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1650                                 SVt_PVAV)));
1651             GvMULTI_on(tmpgv);
1652             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1653         }
1654
1655         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1656             av_extend(PL_dbargs, AvFILLp(ary) + off);
1657         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1658         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1659     }
1660     /* XXX only hints propagated via op_private are currently
1661      * visible (others are not easily accessible, since they
1662      * use the global PL_hints) */
1663     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1664                              HINT_PRIVATE_MASK)));
1665     {
1666         SV * mask ;
1667         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1668
1669         if  (old_warnings == pWARN_NONE ||
1670                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1671             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1672         else if (old_warnings == pWARN_ALL ||
1673                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1674             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1675         else
1676             mask = newSVsv(old_warnings);
1677         PUSHs(sv_2mortal(mask));
1678     }
1679     RETURN;
1680 }
1681
1682 PP(pp_reset)
1683 {
1684     dSP;
1685     char *tmps;
1686     STRLEN n_a;
1687
1688     if (MAXARG < 1)
1689         tmps = "";
1690     else
1691         tmps = POPpx;
1692     sv_reset(tmps, CopSTASH(PL_curcop));
1693     PUSHs(&PL_sv_yes);
1694     RETURN;
1695 }
1696
1697 PP(pp_lineseq)
1698 {
1699     return NORMAL;
1700 }
1701
1702 PP(pp_dbstate)
1703 {
1704     PL_curcop = (COP*)PL_op;
1705     TAINT_NOT;          /* Each statement is presumed innocent */
1706     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1707     FREETMPS;
1708
1709     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1710     {
1711         dSP;
1712         register CV *cv;
1713         register PERL_CONTEXT *cx;
1714         I32 gimme = G_ARRAY;
1715         I32 hasargs;
1716         GV *gv;
1717
1718         gv = PL_DBgv;
1719         cv = GvCV(gv);
1720         if (!cv)
1721             DIE(aTHX_ "No DB::DB routine defined");
1722
1723         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1724             /* don't do recursive DB::DB call */
1725             return NORMAL;
1726
1727         ENTER;
1728         SAVETMPS;
1729
1730         SAVEI32(PL_debug);
1731         SAVESTACK_POS();
1732         PL_debug = 0;
1733         hasargs = 0;
1734         SPAGAIN;
1735
1736         push_return(PL_op->op_next);
1737         PUSHBLOCK(cx, CXt_SUB, SP);
1738         PUSHSUB(cx);
1739         CvDEPTH(cv)++;
1740         (void)SvREFCNT_inc(cv);
1741         SAVEVPTR(PL_curpad);
1742         PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1743         RETURNOP(CvSTART(cv));
1744     }
1745     else
1746         return NORMAL;
1747 }
1748
1749 PP(pp_scope)
1750 {
1751     return NORMAL;
1752 }
1753
1754 PP(pp_enteriter)
1755 {
1756     dSP; dMARK;
1757     register PERL_CONTEXT *cx;
1758     I32 gimme = GIMME_V;
1759     SV **svp;
1760     U32 cxtype = CXt_LOOP;
1761 #ifdef USE_ITHREADS
1762     void *iterdata;
1763 #endif
1764
1765     ENTER;
1766     SAVETMPS;
1767
1768 #ifdef USE_THREADS
1769     if (PL_op->op_flags & OPf_SPECIAL) {
1770         svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1771         SAVEGENERICSV(*svp);
1772         *svp = NEWSV(0,0);
1773     }
1774     else
1775 #endif /* USE_THREADS */
1776     if (PL_op->op_targ) {
1777 #ifndef USE_ITHREADS
1778         svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1779         SAVESPTR(*svp);
1780 #else
1781         SAVEPADSV(PL_op->op_targ);
1782         iterdata = (void*)PL_op->op_targ;
1783         cxtype |= CXp_PADVAR;
1784 #endif
1785     }
1786     else {
1787         GV *gv = (GV*)POPs;
1788         svp = &GvSV(gv);                        /* symbol table variable */
1789         SAVEGENERICSV(*svp);
1790         *svp = NEWSV(0,0);
1791 #ifdef USE_ITHREADS
1792         iterdata = (void*)gv;
1793 #endif
1794     }
1795
1796     ENTER;
1797
1798     PUSHBLOCK(cx, cxtype, SP);
1799 #ifdef USE_ITHREADS
1800     PUSHLOOP(cx, iterdata, MARK);
1801 #else
1802     PUSHLOOP(cx, svp, MARK);
1803 #endif
1804     if (PL_op->op_flags & OPf_STACKED) {
1805         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1806         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1807             dPOPss;
1808             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1809                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1810                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1811                  looks_like_number((SV*)cx->blk_loop.iterary) &&
1812                  *SvPVX(cx->blk_loop.iterary) != '0'))
1813             {
1814                  if (SvNV(sv) < IV_MIN ||
1815                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1816                      DIE(aTHX_ "Range iterator outside integer range");
1817                  cx->blk_loop.iterix = SvIV(sv);
1818                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1819             }
1820             else
1821                 cx->blk_loop.iterlval = newSVsv(sv);
1822         }
1823     }
1824     else {
1825         cx->blk_loop.iterary = PL_curstack;
1826         AvFILLp(PL_curstack) = SP - PL_stack_base;
1827         cx->blk_loop.iterix = MARK - PL_stack_base;
1828     }
1829
1830     RETURN;
1831 }
1832
1833 PP(pp_enterloop)
1834 {
1835     dSP;
1836     register PERL_CONTEXT *cx;
1837     I32 gimme = GIMME_V;
1838
1839     ENTER;
1840     SAVETMPS;
1841     ENTER;
1842
1843     PUSHBLOCK(cx, CXt_LOOP, SP);
1844     PUSHLOOP(cx, 0, SP);
1845
1846     RETURN;
1847 }
1848
1849 PP(pp_leaveloop)
1850 {
1851     dSP;
1852     register PERL_CONTEXT *cx;
1853     I32 gimme;
1854     SV **newsp;
1855     PMOP *newpm;
1856     SV **mark;
1857
1858     POPBLOCK(cx,newpm);
1859     mark = newsp;
1860     newsp = PL_stack_base + cx->blk_loop.resetsp;
1861
1862     TAINT_NOT;
1863     if (gimme == G_VOID)
1864         ; /* do nothing */
1865     else if (gimme == G_SCALAR) {
1866         if (mark < SP)
1867             *++newsp = sv_mortalcopy(*SP);
1868         else
1869             *++newsp = &PL_sv_undef;
1870     }
1871     else {
1872         while (mark < SP) {
1873             *++newsp = sv_mortalcopy(*++mark);
1874             TAINT_NOT;          /* Each item is independent */
1875         }
1876     }
1877     SP = newsp;
1878     PUTBACK;
1879
1880     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1881     PL_curpm = newpm;   /* ... and pop $1 et al */
1882
1883     LEAVE;
1884     LEAVE;
1885
1886     return NORMAL;
1887 }
1888
1889 PP(pp_return)
1890 {
1891     dSP; dMARK;
1892     I32 cxix;
1893     register PERL_CONTEXT *cx;
1894     bool popsub2 = FALSE;
1895     bool clear_errsv = FALSE;
1896     I32 gimme;
1897     SV **newsp;
1898     PMOP *newpm;
1899     I32 optype = 0;
1900     SV *sv;
1901
1902     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1903         if (cxstack_ix == PL_sortcxix
1904             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1905         {
1906             if (cxstack_ix > PL_sortcxix)
1907                 dounwind(PL_sortcxix);
1908             AvARRAY(PL_curstack)[1] = *SP;
1909             PL_stack_sp = PL_stack_base + 1;
1910             return 0;
1911         }
1912     }
1913
1914     cxix = dopoptosub(cxstack_ix);
1915     if (cxix < 0)
1916         DIE(aTHX_ "Can't return outside a subroutine");
1917     if (cxix < cxstack_ix)
1918         dounwind(cxix);
1919
1920     POPBLOCK(cx,newpm);
1921     switch (CxTYPE(cx)) {
1922     case CXt_SUB:
1923         popsub2 = TRUE;
1924         break;
1925     case CXt_EVAL:
1926         if (!(PL_in_eval & EVAL_KEEPERR))
1927             clear_errsv = TRUE;
1928         POPEVAL(cx);
1929         if (CxTRYBLOCK(cx))
1930             break;
1931         lex_end();
1932         if (optype == OP_REQUIRE &&
1933             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1934         {
1935             /* Unassume the success we assumed earlier. */
1936             SV *nsv = cx->blk_eval.old_namesv;
1937             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1938             DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1939         }
1940         break;
1941     case CXt_FORMAT:
1942         POPFORMAT(cx);
1943         break;
1944     default:
1945         DIE(aTHX_ "panic: return");
1946     }
1947
1948     TAINT_NOT;
1949     if (gimme == G_SCALAR) {
1950         if (MARK < SP) {
1951             if (popsub2) {
1952                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1953                     if (SvTEMP(TOPs)) {
1954                         *++newsp = SvREFCNT_inc(*SP);
1955                         FREETMPS;
1956                         sv_2mortal(*newsp);
1957                     }
1958                     else {
1959                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1960                         FREETMPS;
1961                         *++newsp = sv_mortalcopy(sv);
1962                         SvREFCNT_dec(sv);
1963                     }
1964                 }
1965                 else
1966                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1967             }
1968             else
1969                 *++newsp = sv_mortalcopy(*SP);
1970         }
1971         else
1972             *++newsp = &PL_sv_undef;
1973     }
1974     else if (gimme == G_ARRAY) {
1975         while (++MARK <= SP) {
1976             *++newsp = (popsub2 && SvTEMP(*MARK))
1977                         ? *MARK : sv_mortalcopy(*MARK);
1978             TAINT_NOT;          /* Each item is independent */
1979         }
1980     }
1981     PL_stack_sp = newsp;
1982
1983     /* Stack values are safe: */
1984     if (popsub2) {
1985         POPSUB(cx,sv);  /* release CV and @_ ... */
1986     }
1987     else
1988         sv = Nullsv;
1989     PL_curpm = newpm;   /* ... and pop $1 et al */
1990
1991     LEAVE;
1992     LEAVESUB(sv);
1993     if (clear_errsv)
1994         sv_setpv(ERRSV,"");
1995     return pop_return();
1996 }
1997
1998 PP(pp_last)
1999 {
2000     dSP;
2001     I32 cxix;
2002     register PERL_CONTEXT *cx;
2003     I32 pop2 = 0;
2004     I32 gimme;
2005     I32 optype;
2006     OP *nextop;
2007     SV **newsp;
2008     PMOP *newpm;
2009     SV **mark;
2010     SV *sv = Nullsv;
2011
2012     if (PL_op->op_flags & OPf_SPECIAL) {
2013         cxix = dopoptoloop(cxstack_ix);
2014         if (cxix < 0)
2015             DIE(aTHX_ "Can't \"last\" outside a loop block");
2016     }
2017     else {
2018         cxix = dopoptolabel(cPVOP->op_pv);
2019         if (cxix < 0)
2020             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2021     }
2022     if (cxix < cxstack_ix)
2023         dounwind(cxix);
2024
2025     POPBLOCK(cx,newpm);
2026     mark = newsp;
2027     switch (CxTYPE(cx)) {
2028     case CXt_LOOP:
2029         pop2 = CXt_LOOP;
2030         newsp = PL_stack_base + cx->blk_loop.resetsp;
2031         nextop = cx->blk_loop.last_op->op_next;
2032         break;
2033     case CXt_SUB:
2034         pop2 = CXt_SUB;
2035         nextop = pop_return();
2036         break;
2037     case CXt_EVAL:
2038         POPEVAL(cx);
2039         nextop = pop_return();
2040         break;
2041     case CXt_FORMAT:
2042         POPFORMAT(cx);
2043         nextop = pop_return();
2044         break;
2045     default:
2046         DIE(aTHX_ "panic: last");
2047     }
2048
2049     TAINT_NOT;
2050     if (gimme == G_SCALAR) {
2051         if (MARK < SP)
2052             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2053                         ? *SP : sv_mortalcopy(*SP);
2054         else
2055             *++newsp = &PL_sv_undef;
2056     }
2057     else if (gimme == G_ARRAY) {
2058         while (++MARK <= SP) {
2059             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2060                         ? *MARK : sv_mortalcopy(*MARK);
2061             TAINT_NOT;          /* Each item is independent */
2062         }
2063     }
2064     SP = newsp;
2065     PUTBACK;
2066
2067     /* Stack values are safe: */
2068     switch (pop2) {
2069     case CXt_LOOP:
2070         POPLOOP(cx);    /* release loop vars ... */
2071         LEAVE;
2072         break;
2073     case CXt_SUB:
2074         POPSUB(cx,sv);  /* release CV and @_ ... */
2075         break;
2076     }
2077     PL_curpm = newpm;   /* ... and pop $1 et al */
2078
2079     LEAVE;
2080     LEAVESUB(sv);
2081     return nextop;
2082 }
2083
2084 PP(pp_next)
2085 {
2086     I32 cxix;
2087     register PERL_CONTEXT *cx;
2088     I32 inner;
2089
2090     if (PL_op->op_flags & OPf_SPECIAL) {
2091         cxix = dopoptoloop(cxstack_ix);
2092         if (cxix < 0)
2093             DIE(aTHX_ "Can't \"next\" outside a loop block");
2094     }
2095     else {
2096         cxix = dopoptolabel(cPVOP->op_pv);
2097         if (cxix < 0)
2098             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2099     }
2100     if (cxix < cxstack_ix)
2101         dounwind(cxix);
2102
2103     /* clear off anything above the scope we're re-entering, but
2104      * save the rest until after a possible continue block */
2105     inner = PL_scopestack_ix;
2106     TOPBLOCK(cx);
2107     if (PL_scopestack_ix < inner)
2108         leave_scope(PL_scopestack[PL_scopestack_ix]);
2109     return cx->blk_loop.next_op;
2110 }
2111
2112 PP(pp_redo)
2113 {
2114     I32 cxix;
2115     register PERL_CONTEXT *cx;
2116     I32 oldsave;
2117
2118     if (PL_op->op_flags & OPf_SPECIAL) {
2119         cxix = dopoptoloop(cxstack_ix);
2120         if (cxix < 0)
2121             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2122     }
2123     else {
2124         cxix = dopoptolabel(cPVOP->op_pv);
2125         if (cxix < 0)
2126             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2127     }
2128     if (cxix < cxstack_ix)
2129         dounwind(cxix);
2130
2131     TOPBLOCK(cx);
2132     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2133     LEAVE_SCOPE(oldsave);
2134     return cx->blk_loop.redo_op;
2135 }
2136
2137 STATIC OP *
2138 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2139 {
2140     OP *kid;
2141     OP **ops = opstack;
2142     static char too_deep[] = "Target of goto is too deeply nested";
2143
2144     if (ops >= oplimit)
2145         Perl_croak(aTHX_ too_deep);
2146     if (o->op_type == OP_LEAVE ||
2147         o->op_type == OP_SCOPE ||
2148         o->op_type == OP_LEAVELOOP ||
2149         o->op_type == OP_LEAVETRY)
2150     {
2151         *ops++ = cUNOPo->op_first;
2152         if (ops >= oplimit)
2153             Perl_croak(aTHX_ too_deep);
2154     }
2155     *ops = 0;
2156     if (o->op_flags & OPf_KIDS) {
2157         /* First try all the kids at this level, since that's likeliest. */
2158         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2159             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2160                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2161                 return kid;
2162         }
2163         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2164             if (kid == PL_lastgotoprobe)
2165                 continue;
2166             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2167                 (ops == opstack ||
2168                  (ops[-1]->op_type != OP_NEXTSTATE &&
2169                   ops[-1]->op_type != OP_DBSTATE)))
2170                 *ops++ = kid;
2171             if ((o = dofindlabel(kid, label, ops, oplimit)))
2172                 return o;
2173         }
2174     }
2175     *ops = 0;
2176     return 0;
2177 }
2178
2179 PP(pp_dump)
2180 {
2181     return pp_goto();
2182     /*NOTREACHED*/
2183 }
2184
2185 PP(pp_goto)
2186 {
2187     dSP;
2188     OP *retop = 0;
2189     I32 ix;
2190     register PERL_CONTEXT *cx;
2191 #define GOTO_DEPTH 64
2192     OP *enterops[GOTO_DEPTH];
2193     char *label;
2194     int do_dump = (PL_op->op_type == OP_DUMP);
2195     static char must_have_label[] = "goto must have label";
2196
2197     label = 0;
2198     if (PL_op->op_flags & OPf_STACKED) {
2199         SV *sv = POPs;
2200         STRLEN n_a;
2201
2202         /* This egregious kludge implements goto &subroutine */
2203         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2204             I32 cxix;
2205             register PERL_CONTEXT *cx;
2206             CV* cv = (CV*)SvRV(sv);
2207             SV** mark;
2208             I32 items = 0;
2209             I32 oldsave;
2210
2211         retry:
2212             if (!CvROOT(cv) && !CvXSUB(cv)) {
2213                 GV *gv = CvGV(cv);
2214                 GV *autogv;
2215                 if (gv) {
2216                     SV *tmpstr;
2217                     /* autoloaded stub? */
2218                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2219                         goto retry;
2220                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2221                                           GvNAMELEN(gv), FALSE);
2222                     if (autogv && (cv = GvCV(autogv)))
2223                         goto retry;
2224                     tmpstr = sv_newmortal();
2225                     gv_efullname3(tmpstr, gv, Nullch);
2226                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2227                 }
2228                 DIE(aTHX_ "Goto undefined subroutine");
2229             }
2230
2231             /* First do some returnish stuff. */
2232             cxix = dopoptosub(cxstack_ix);
2233             if (cxix < 0)
2234                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2235             if (cxix < cxstack_ix)
2236                 dounwind(cxix);
2237             TOPBLOCK(cx);
2238             if (CxREALEVAL(cx))
2239                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2240             mark = PL_stack_sp;
2241             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2242                 /* put @_ back onto stack */
2243                 AV* av = cx->blk_sub.argarray;
2244
2245                 items = AvFILLp(av) + 1;
2246                 PL_stack_sp++;
2247                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2248                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2249                 PL_stack_sp += items;
2250 #ifndef USE_THREADS
2251                 SvREFCNT_dec(GvAV(PL_defgv));
2252                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2253 #endif /* USE_THREADS */
2254                 /* abandon @_ if it got reified */
2255                 if (AvREAL(av)) {
2256                     (void)sv_2mortal((SV*)av);  /* delay until return */
2257                     av = newAV();
2258                     av_extend(av, items-1);
2259                     AvFLAGS(av) = AVf_REIFY;
2260                     PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2261                 }
2262             }
2263             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2264                 AV* av;
2265 #ifdef USE_THREADS
2266                 av = (AV*)PL_curpad[0];
2267 #else
2268                 av = GvAV(PL_defgv);
2269 #endif
2270                 items = AvFILLp(av) + 1;
2271                 PL_stack_sp++;
2272                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2273                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2274                 PL_stack_sp += items;
2275             }
2276             if (CxTYPE(cx) == CXt_SUB &&
2277                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2278                 SvREFCNT_dec(cx->blk_sub.cv);
2279             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2280             LEAVE_SCOPE(oldsave);
2281
2282             /* Now do some callish stuff. */
2283             SAVETMPS;
2284             if (CvXSUB(cv)) {
2285 #ifdef PERL_XSUB_OLDSTYLE
2286                 if (CvOLDSTYLE(cv)) {
2287                     I32 (*fp3)(int,int,int);
2288                     while (SP > mark) {
2289                         SP[1] = SP[0];
2290                         SP--;
2291                     }
2292                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2293                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2294                                    mark - PL_stack_base + 1,
2295                                    items);
2296                     SP = PL_stack_base + items;
2297                 }
2298                 else
2299 #endif /* PERL_XSUB_OLDSTYLE */
2300                 {
2301                     SV **newsp;
2302                     I32 gimme;
2303
2304                     PL_stack_sp--;              /* There is no cv arg. */
2305                     /* Push a mark for the start of arglist */
2306                     PUSHMARK(mark);
2307                     (void)(*CvXSUB(cv))(aTHXo_ cv);
2308                     /* Pop the current context like a decent sub should */
2309                     POPBLOCK(cx, PL_curpm);
2310                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2311                 }
2312                 LEAVE;
2313                 return pop_return();
2314             }
2315             else {
2316                 AV* padlist = CvPADLIST(cv);
2317                 SV** svp = AvARRAY(padlist);
2318                 if (CxTYPE(cx) == CXt_EVAL) {
2319                     PL_in_eval = cx->blk_eval.old_in_eval;
2320                     PL_eval_root = cx->blk_eval.old_eval_root;
2321                     cx->cx_type = CXt_SUB;
2322                     cx->blk_sub.hasargs = 0;
2323                 }
2324                 cx->blk_sub.cv = cv;
2325                 cx->blk_sub.olddepth = CvDEPTH(cv);
2326                 CvDEPTH(cv)++;
2327                 if (CvDEPTH(cv) < 2)
2328                     (void)SvREFCNT_inc(cv);
2329                 else {  /* save temporaries on recursion? */
2330                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2331                         sub_crush_depth(cv);
2332                     if (CvDEPTH(cv) > AvFILLp(padlist)) {
2333                         AV *newpad = newAV();
2334                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2335                         I32 ix = AvFILLp((AV*)svp[1]);
2336                         I32 names_fill = AvFILLp((AV*)svp[0]);
2337                         svp = AvARRAY(svp[0]);
2338                         for ( ;ix > 0; ix--) {
2339                             if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2340                                 char *name = SvPVX(svp[ix]);
2341                                 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2342                                     || *name == '&')
2343                                 {
2344                                     /* outer lexical or anon code */
2345                                     av_store(newpad, ix,
2346                                         SvREFCNT_inc(oldpad[ix]) );
2347                                 }
2348                                 else {          /* our own lexical */
2349                                     if (*name == '@')
2350                                         av_store(newpad, ix, sv = (SV*)newAV());
2351                                     else if (*name == '%')
2352                                         av_store(newpad, ix, sv = (SV*)newHV());
2353                                     else
2354                                         av_store(newpad, ix, sv = NEWSV(0,0));
2355                                     SvPADMY_on(sv);
2356                                 }
2357                             }
2358                             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2359                                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2360                             }
2361                             else {
2362                                 av_store(newpad, ix, sv = NEWSV(0,0));
2363                                 SvPADTMP_on(sv);
2364                             }
2365                         }
2366                         if (cx->blk_sub.hasargs) {
2367                             AV* av = newAV();
2368                             av_extend(av, 0);
2369                             av_store(newpad, 0, (SV*)av);
2370                             AvFLAGS(av) = AVf_REIFY;
2371                         }
2372                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2373                         AvFILLp(padlist) = CvDEPTH(cv);
2374                         svp = AvARRAY(padlist);
2375                     }
2376                 }
2377 #ifdef USE_THREADS
2378                 if (!cx->blk_sub.hasargs) {
2379                     AV* av = (AV*)PL_curpad[0];
2380
2381                     items = AvFILLp(av) + 1;
2382                     if (items) {
2383                         /* Mark is at the end of the stack. */
2384                         EXTEND(SP, items);
2385                         Copy(AvARRAY(av), SP + 1, items, SV*);
2386                         SP += items;
2387                         PUTBACK ;
2388                     }
2389                 }
2390 #endif /* USE_THREADS */
2391                 SAVEVPTR(PL_curpad);
2392                 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2393 #ifndef USE_THREADS
2394                 if (cx->blk_sub.hasargs)
2395 #endif /* USE_THREADS */
2396                 {
2397                     AV* av = (AV*)PL_curpad[0];
2398                     SV** ary;
2399
2400 #ifndef USE_THREADS
2401                     cx->blk_sub.savearray = GvAV(PL_defgv);
2402                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2403 #endif /* USE_THREADS */
2404                     cx->blk_sub.oldcurpad = PL_curpad;
2405                     cx->blk_sub.argarray = av;
2406                     ++mark;
2407
2408                     if (items >= AvMAX(av) + 1) {
2409                         ary = AvALLOC(av);
2410                         if (AvARRAY(av) != ary) {
2411                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2412                             SvPVX(av) = (char*)ary;
2413                         }
2414                         if (items >= AvMAX(av) + 1) {
2415                             AvMAX(av) = items - 1;
2416                             Renew(ary,items+1,SV*);
2417                             AvALLOC(av) = ary;
2418                             SvPVX(av) = (char*)ary;
2419                         }
2420                     }
2421                     Copy(mark,AvARRAY(av),items,SV*);
2422                     AvFILLp(av) = items - 1;
2423                     assert(!AvREAL(av));
2424                     while (items--) {
2425                         if (*mark)
2426                             SvTEMP_off(*mark);
2427                         mark++;
2428                     }
2429                 }
2430                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2431                     /*
2432                      * We do not care about using sv to call CV;
2433                      * it's for informational purposes only.
2434                      */
2435                     SV *sv = GvSV(PL_DBsub);
2436                     CV *gotocv;
2437
2438                     if (PERLDB_SUB_NN) {
2439                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2440                     } else {
2441                         save_item(sv);
2442                         gv_efullname3(sv, CvGV(cv), Nullch);
2443                     }
2444                     if (  PERLDB_GOTO
2445                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2446                         PUSHMARK( PL_stack_sp );
2447                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2448                         PL_stack_sp--;
2449                     }
2450                 }
2451                 RETURNOP(CvSTART(cv));
2452             }
2453         }
2454         else {
2455             label = SvPV(sv,n_a);
2456             if (!(do_dump || *label))
2457                 DIE(aTHX_ must_have_label);
2458         }
2459     }
2460     else if (PL_op->op_flags & OPf_SPECIAL) {
2461         if (! do_dump)
2462             DIE(aTHX_ must_have_label);
2463     }
2464     else
2465         label = cPVOP->op_pv;
2466
2467     if (label && *label) {
2468         OP *gotoprobe = 0;
2469         bool leaving_eval = FALSE;
2470         PERL_CONTEXT *last_eval_cx = 0;
2471
2472         /* find label */
2473
2474         PL_lastgotoprobe = 0;
2475         *enterops = 0;
2476         for (ix = cxstack_ix; ix >= 0; ix--) {
2477             cx = &cxstack[ix];
2478             switch (CxTYPE(cx)) {
2479             case CXt_EVAL:
2480                 leaving_eval = TRUE;
2481                 if (CxREALEVAL(cx)) {
2482                     gotoprobe = (last_eval_cx ?
2483                                 last_eval_cx->blk_eval.old_eval_root :
2484                                 PL_eval_root);
2485                     last_eval_cx = cx;
2486                     break;
2487                 }
2488                 /* else fall through */
2489             case CXt_LOOP:
2490                 gotoprobe = cx->blk_oldcop->op_sibling;
2491                 break;
2492             case CXt_SUBST:
2493                 continue;
2494             case CXt_BLOCK:
2495                 if (ix)
2496                     gotoprobe = cx->blk_oldcop->op_sibling;
2497                 else
2498                     gotoprobe = PL_main_root;
2499                 break;
2500             case CXt_SUB:
2501                 if (CvDEPTH(cx->blk_sub.cv)) {
2502                     gotoprobe = CvROOT(cx->blk_sub.cv);
2503                     break;
2504                 }
2505                 /* FALL THROUGH */
2506             case CXt_FORMAT:
2507             case CXt_NULL:
2508                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2509             default:
2510                 if (ix)
2511                     DIE(aTHX_ "panic: goto");
2512                 gotoprobe = PL_main_root;
2513                 break;
2514             }
2515             if (gotoprobe) {
2516                 retop = dofindlabel(gotoprobe, label,
2517                                     enterops, enterops + GOTO_DEPTH);
2518                 if (retop)
2519                     break;
2520             }
2521             PL_lastgotoprobe = gotoprobe;
2522         }
2523         if (!retop)
2524             DIE(aTHX_ "Can't find label %s", label);
2525
2526         /* if we're leaving an eval, check before we pop any frames
2527            that we're not going to punt, otherwise the error
2528            won't be caught */
2529
2530         if (leaving_eval && *enterops && enterops[1]) {
2531             I32 i;
2532             for (i = 1; enterops[i]; i++)
2533                 if (enterops[i]->op_type == OP_ENTERITER)
2534                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2535         }
2536
2537         /* pop unwanted frames */
2538
2539         if (ix < cxstack_ix) {
2540             I32 oldsave;
2541
2542             if (ix < 0)
2543                 ix = 0;
2544             dounwind(ix);
2545             TOPBLOCK(cx);
2546             oldsave = PL_scopestack[PL_scopestack_ix];
2547             LEAVE_SCOPE(oldsave);
2548         }
2549
2550         /* push wanted frames */
2551
2552         if (*enterops && enterops[1]) {
2553             OP *oldop = PL_op;
2554             for (ix = 1; enterops[ix]; ix++) {
2555                 PL_op = enterops[ix];
2556                 /* Eventually we may want to stack the needed arguments
2557                  * for each op.  For now, we punt on the hard ones. */
2558                 if (PL_op->op_type == OP_ENTERITER)
2559                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2560                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2561             }
2562             PL_op = oldop;
2563         }
2564     }
2565
2566     if (do_dump) {
2567 #ifdef VMS
2568         if (!retop) retop = PL_main_start;
2569 #endif
2570         PL_restartop = retop;
2571         PL_do_undump = TRUE;
2572
2573         my_unexec();
2574
2575         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2576         PL_do_undump = FALSE;
2577     }
2578
2579     RETURNOP(retop);
2580 }
2581
2582 PP(pp_exit)
2583 {
2584     dSP;
2585     I32 anum;
2586
2587     if (MAXARG < 1)
2588         anum = 0;
2589     else {
2590         anum = SvIVx(POPs);
2591 #ifdef VMS
2592         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2593             anum = 0;
2594 #endif
2595     }
2596     PL_exit_flags |= PERL_EXIT_EXPECTED;
2597     my_exit(anum);
2598     PUSHs(&PL_sv_undef);
2599     RETURN;
2600 }
2601
2602 #ifdef NOTYET
2603 PP(pp_nswitch)
2604 {
2605     dSP;
2606     NV value = SvNVx(GvSV(cCOP->cop_gv));
2607     register I32 match = I_32(value);
2608
2609     if (value < 0.0) {
2610         if (((NV)match) > value)
2611             --match;            /* was fractional--truncate other way */
2612     }
2613     match -= cCOP->uop.scop.scop_offset;
2614     if (match < 0)
2615         match = 0;
2616     else if (match > cCOP->uop.scop.scop_max)
2617         match = cCOP->uop.scop.scop_max;
2618     PL_op = cCOP->uop.scop.scop_next[match];
2619     RETURNOP(PL_op);
2620 }
2621
2622 PP(pp_cswitch)
2623 {
2624     dSP;
2625     register I32 match;
2626
2627     if (PL_multiline)
2628         PL_op = PL_op->op_next;                 /* can't assume anything */
2629     else {
2630         STRLEN n_a;
2631         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2632         match -= cCOP->uop.scop.scop_offset;
2633         if (match < 0)
2634             match = 0;
2635         else if (match > cCOP->uop.scop.scop_max)
2636             match = cCOP->uop.scop.scop_max;
2637         PL_op = cCOP->uop.scop.scop_next[match];
2638     }
2639     RETURNOP(PL_op);
2640 }
2641 #endif
2642
2643 /* Eval. */
2644
2645 STATIC void
2646 S_save_lines(pTHX_ AV *array, SV *sv)
2647 {
2648     register char *s = SvPVX(sv);
2649     register char *send = SvPVX(sv) + SvCUR(sv);
2650     register char *t;
2651     register I32 line = 1;
2652
2653     while (s && s < send) {
2654         SV *tmpstr = NEWSV(85,0);
2655
2656         sv_upgrade(tmpstr, SVt_PVMG);
2657         t = strchr(s, '\n');
2658         if (t)
2659             t++;
2660         else
2661             t = send;
2662
2663         sv_setpvn(tmpstr, s, t - s);
2664         av_store(array, line++, tmpstr);
2665         s = t;
2666     }
2667 }
2668
2669 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2670 STATIC void *
2671 S_docatch_body(pTHX_ va_list args)
2672 {
2673     return docatch_body();
2674 }
2675 #endif
2676
2677 STATIC void *
2678 S_docatch_body(pTHX)
2679 {
2680     CALLRUNOPS(aTHX);
2681     return NULL;
2682 }
2683
2684 STATIC OP *
2685 S_docatch(pTHX_ OP *o)
2686 {
2687     int ret;
2688     OP *oldop = PL_op;
2689     volatile PERL_SI *cursi = PL_curstackinfo;
2690     dJMPENV;
2691
2692 #ifdef DEBUGGING
2693     assert(CATCH_GET == TRUE);
2694 #endif
2695     PL_op = o;
2696 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2697  redo_body:
2698     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2699 #else
2700     JMPENV_PUSH(ret);
2701 #endif
2702     switch (ret) {
2703     case 0:
2704 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2705  redo_body:
2706         docatch_body();
2707 #endif
2708         break;
2709     case 3:
2710         if (PL_restartop && cursi == PL_curstackinfo) {
2711             PL_op = PL_restartop;
2712             PL_restartop = 0;
2713             goto redo_body;
2714         }
2715         /* FALL THROUGH */
2716     default:
2717         JMPENV_POP;
2718         PL_op = oldop;
2719         JMPENV_JUMP(ret);
2720         /* NOTREACHED */
2721     }
2722     JMPENV_POP;
2723     PL_op = oldop;
2724     return Nullop;
2725 }
2726
2727 OP *
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2732 {
2733     dSP;                                /* Make POPBLOCK work. */
2734     PERL_CONTEXT *cx;
2735     SV **newsp;
2736     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2737     I32 optype;
2738     OP dummy;
2739     OP *rop;
2740     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741     char *tmpbuf = tbuf;
2742     char *safestr;
2743
2744     ENTER;
2745     lex_start(sv);
2746     SAVETMPS;
2747     /* switch to eval mode */
2748
2749     if (PL_curcop == &PL_compiling) {
2750         SAVECOPSTASH_FREE(&PL_compiling);
2751         CopSTASH_set(&PL_compiling, PL_curstash);
2752     }
2753     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2754         SV *sv = sv_newmortal();
2755         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2756                        code, (unsigned long)++PL_evalseq,
2757                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2758         tmpbuf = SvPVX(sv);
2759     }
2760     else
2761         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2762     SAVECOPFILE_FREE(&PL_compiling);
2763     CopFILE_set(&PL_compiling, tmpbuf+2);
2764     SAVECOPLINE(&PL_compiling);
2765     CopLINE_set(&PL_compiling, 1);
2766     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2767        deleting the eval's FILEGV from the stash before gv_check() runs
2768        (i.e. before run-time proper). To work around the coredump that
2769        ensues, we always turn GvMULTI_on for any globals that were
2770        introduced within evals. See force_ident(). GSAR 96-10-12 */
2771     safestr = savepv(tmpbuf);
2772     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2773     SAVEHINTS();
2774 #ifdef OP_IN_REGISTER
2775     PL_opsave = op;
2776 #else
2777     SAVEVPTR(PL_op);
2778 #endif
2779     PL_hints &= HINT_UTF8;
2780
2781     PL_op = &dummy;
2782     PL_op->op_type = OP_ENTEREVAL;
2783     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2784     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2785     PUSHEVAL(cx, 0, Nullgv);
2786     rop = doeval(G_SCALAR, startop);
2787     POPBLOCK(cx,PL_curpm);
2788     POPEVAL(cx);
2789
2790     (*startop)->op_type = OP_NULL;
2791     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2792     lex_end();
2793     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2794     LEAVE;
2795     if (PL_curcop == &PL_compiling)
2796         PL_compiling.op_private = PL_hints;
2797 #ifdef OP_IN_REGISTER
2798     op = PL_opsave;
2799 #endif
2800     return rop;
2801 }
2802
2803 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2804 STATIC OP *
2805 S_doeval(pTHX_ int gimme, OP** startop)
2806 {
2807     dSP;
2808     OP *saveop = PL_op;
2809     CV *caller;
2810     AV* comppadlist;
2811     I32 i;
2812
2813     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2814                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2815                   : EVAL_INEVAL);
2816
2817     PUSHMARK(SP);
2818
2819     /* set up a scratch pad */
2820
2821     SAVEI32(PL_padix);
2822     SAVEVPTR(PL_curpad);
2823     SAVESPTR(PL_comppad);
2824     SAVESPTR(PL_comppad_name);
2825     SAVEI32(PL_comppad_name_fill);
2826     SAVEI32(PL_min_intro_pending);
2827     SAVEI32(PL_max_intro_pending);
2828
2829     caller = PL_compcv;
2830     for (i = cxstack_ix - 1; i >= 0; i--) {
2831         PERL_CONTEXT *cx = &cxstack[i];
2832         if (CxTYPE(cx) == CXt_EVAL)
2833             break;
2834         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2835             caller = cx->blk_sub.cv;
2836             break;
2837         }
2838     }
2839
2840     SAVESPTR(PL_compcv);
2841     PL_compcv = (CV*)NEWSV(1104,0);
2842     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2843     CvEVAL_on(PL_compcv);
2844     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2845     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2846
2847 #ifdef USE_THREADS
2848     CvOWNER(PL_compcv) = 0;
2849     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2850     MUTEX_INIT(CvMUTEXP(PL_compcv));
2851 #endif /* USE_THREADS */
2852
2853     PL_comppad = newAV();
2854     av_push(PL_comppad, Nullsv);
2855     PL_curpad = AvARRAY(PL_comppad);
2856     PL_comppad_name = newAV();
2857     PL_comppad_name_fill = 0;
2858     PL_min_intro_pending = 0;
2859     PL_padix = 0;
2860 #ifdef USE_THREADS
2861     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2862     PL_curpad[0] = (SV*)newAV();
2863     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2864 #endif /* USE_THREADS */
2865
2866     comppadlist = newAV();
2867     AvREAL_off(comppadlist);
2868     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2869     av_store(comppadlist, 1, (SV*)PL_comppad);
2870     CvPADLIST(PL_compcv) = comppadlist;
2871
2872     if (!saveop ||
2873         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2874     {
2875         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2876     }
2877
2878     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2879
2880     /* make sure we compile in the right package */
2881
2882     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2883         SAVESPTR(PL_curstash);
2884         PL_curstash = CopSTASH(PL_curcop);
2885     }
2886     SAVESPTR(PL_beginav);
2887     PL_beginav = newAV();
2888     SAVEFREESV(PL_beginav);
2889     SAVEI32(PL_error_count);
2890
2891     /* try to compile it */
2892
2893     PL_eval_root = Nullop;
2894     PL_error_count = 0;
2895     PL_curcop = &PL_compiling;
2896     PL_curcop->cop_arybase = 0;
2897     SvREFCNT_dec(PL_rs);
2898     PL_rs = newSVpvn("\n", 1);
2899     if (saveop && saveop->op_flags & OPf_SPECIAL)
2900         PL_in_eval |= EVAL_KEEPERR;
2901     else
2902         sv_setpv(ERRSV,"");
2903     if (yyparse() || PL_error_count || !PL_eval_root) {
2904         SV **newsp;
2905         I32 gimme;
2906         PERL_CONTEXT *cx;
2907         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2908         STRLEN n_a;
2909
2910         PL_op = saveop;
2911         if (PL_eval_root) {
2912             op_free(PL_eval_root);
2913             PL_eval_root = Nullop;
2914         }
2915         SP = PL_stack_base + POPMARK;           /* pop original mark */
2916         if (!startop) {
2917             POPBLOCK(cx,PL_curpm);
2918             POPEVAL(cx);
2919             pop_return();
2920         }
2921         lex_end();
2922         LEAVE;
2923         if (optype == OP_REQUIRE) {
2924             char* msg = SvPVx(ERRSV, n_a);
2925             DIE(aTHX_ "%sCompilation failed in require",
2926                 *msg ? msg : "Unknown error\n");
2927         }
2928         else if (startop) {
2929             char* msg = SvPVx(ERRSV, n_a);
2930
2931             POPBLOCK(cx,PL_curpm);
2932             POPEVAL(cx);
2933             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2934                        (*msg ? msg : "Unknown error\n"));
2935         }
2936         SvREFCNT_dec(PL_rs);
2937         PL_rs = SvREFCNT_inc(PL_nrs);
2938 #ifdef USE_THREADS
2939         MUTEX_LOCK(&PL_eval_mutex);
2940         PL_eval_owner = 0;
2941         COND_SIGNAL(&PL_eval_cond);
2942         MUTEX_UNLOCK(&PL_eval_mutex);
2943 #endif /* USE_THREADS */
2944         RETPUSHUNDEF;
2945     }
2946     SvREFCNT_dec(PL_rs);
2947     PL_rs = SvREFCNT_inc(PL_nrs);
2948     CopLINE_set(&PL_compiling, 0);
2949     if (startop) {
2950         *startop = PL_eval_root;
2951         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2952         CvOUTSIDE(PL_compcv) = Nullcv;
2953     } else
2954         SAVEFREEOP(PL_eval_root);
2955     if (gimme & G_VOID)
2956         scalarvoid(PL_eval_root);
2957     else if (gimme & G_ARRAY)
2958         list(PL_eval_root);
2959     else
2960         scalar(PL_eval_root);
2961
2962     DEBUG_x(dump_eval());
2963
2964     /* Register with debugger: */
2965     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2966         CV *cv = get_cv("DB::postponed", FALSE);
2967         if (cv) {
2968             dSP;
2969             PUSHMARK(SP);
2970             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2971             PUTBACK;
2972             call_sv((SV*)cv, G_DISCARD);
2973         }
2974     }
2975
2976     /* compiled okay, so do it */
2977
2978     CvDEPTH(PL_compcv) = 1;
2979     SP = PL_stack_base + POPMARK;               /* pop original mark */
2980     PL_op = saveop;                     /* The caller may need it. */
2981     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2982 #ifdef USE_THREADS
2983     MUTEX_LOCK(&PL_eval_mutex);
2984     PL_eval_owner = 0;
2985     COND_SIGNAL(&PL_eval_cond);
2986     MUTEX_UNLOCK(&PL_eval_mutex);
2987 #endif /* USE_THREADS */
2988
2989     RETURNOP(PL_eval_start);
2990 }
2991
2992 STATIC PerlIO *
2993 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2994 {
2995     STRLEN namelen = strlen(name);
2996     PerlIO *fp;
2997
2998     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2999         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3000         char *pmc = SvPV_nolen(pmcsv);
3001         Stat_t pmstat;
3002         Stat_t pmcstat;
3003         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3004             fp = PerlIO_open(name, mode);
3005         }
3006         else {
3007             if (PerlLIO_stat(name, &pmstat) < 0 ||
3008                 pmstat.st_mtime < pmcstat.st_mtime)
3009             {
3010                 fp = PerlIO_open(pmc, mode);
3011             }
3012             else {
3013                 fp = PerlIO_open(name, mode);
3014             }
3015         }
3016         SvREFCNT_dec(pmcsv);
3017     }
3018     else {
3019         fp = PerlIO_open(name, mode);
3020     }
3021     return fp;
3022 }
3023
3024 PP(pp_require)
3025 {
3026     dSP;
3027     register PERL_CONTEXT *cx;
3028     SV *sv;
3029     char *name;
3030     STRLEN len;
3031     char *tryname = Nullch;
3032     SV *namesv = Nullsv;
3033     SV** svp;
3034     I32 gimme = GIMME_V;
3035     PerlIO *tryrsfp = 0;
3036     STRLEN n_a;
3037     int filter_has_file = 0;
3038     GV *filter_child_proc = 0;
3039     SV *filter_state = 0;
3040     SV *filter_sub = 0;
3041
3042     sv = POPs;
3043     if (SvNIOKp(sv)) {
3044         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
3045             UV rev = 0, ver = 0, sver = 0;
3046             STRLEN len;
3047             U8 *s = (U8*)SvPVX(sv);
3048             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3049             if (s < end) {
3050                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3051                 s += len;
3052                 if (s < end) {
3053                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3054                     s += len;
3055                     if (s < end)
3056                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3057                 }
3058             }
3059             if (PERL_REVISION < rev
3060                 || (PERL_REVISION == rev
3061                     && (PERL_VERSION < ver
3062                         || (PERL_VERSION == ver
3063                             && PERL_SUBVERSION < sver))))
3064             {
3065                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3066                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3067                     PERL_VERSION, PERL_SUBVERSION);
3068             }
3069             RETPUSHYES;
3070         }
3071         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3072             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3073                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3074                 + 0.00000099 < SvNV(sv))
3075             {
3076                 NV nrev = SvNV(sv);
3077                 UV rev = (UV)nrev;
3078                 NV nver = (nrev - rev) * 1000;
3079                 UV ver = (UV)(nver + 0.0009);
3080                 NV nsver = (nver - ver) * 1000;
3081                 UV sver = (UV)(nsver + 0.0009);
3082
3083                 /* help out with the "use 5.6" confusion */
3084                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3085                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3086                         "this is only v%d.%d.%d, stopped"
3087                         " (did you mean v%"UVuf".%"UVuf".0?)",
3088                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3089                         PERL_SUBVERSION, rev, ver/100);
3090                 }
3091                 else {
3092                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3093                         "this is only v%d.%d.%d, stopped",
3094                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3095                         PERL_SUBVERSION);
3096                 }
3097             }
3098             RETPUSHYES;
3099         }
3100     }
3101     name = SvPV(sv, len);
3102     if (!(name && len > 0 && *name))
3103         DIE(aTHX_ "Null filename used");
3104     TAINT_PROPER("require");
3105     if (PL_op->op_type == OP_REQUIRE &&
3106       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3107       *svp != &PL_sv_undef)
3108         RETPUSHYES;
3109
3110     /* prepare to compile file */
3111
3112 #ifdef MACOS_TRADITIONAL
3113     if (PERL_FILE_IS_ABSOLUTE(name)
3114         || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3115     {
3116         tryname = name;
3117         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3118         /* We consider paths of the form :a:b ambiguous and interpret them first
3119            as global then as local
3120         */
3121         if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3122             goto trylocal;
3123     }
3124     else
3125 trylocal: {
3126 #else
3127     if (PERL_FILE_IS_ABSOLUTE(name)
3128         || (*name == '.' && (name[1] == '/' ||
3129                              (name[1] == '.' && name[2] == '/'))))
3130     {
3131         tryname = name;
3132         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3133     }
3134     else {
3135 #endif
3136         AV *ar = GvAVn(PL_incgv);
3137         I32 i;
3138 #ifdef VMS
3139         char *unixname;
3140         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3141 #endif
3142         {
3143             namesv = NEWSV(806, 0);
3144             for (i = 0; i <= AvFILL(ar); i++) {
3145                 SV *dirsv = *av_fetch(ar, i, TRUE);
3146
3147                 if (SvROK(dirsv)) {
3148                     int count;
3149                     SV *loader = dirsv;
3150
3151                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3152                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3153                     }
3154
3155                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3156                                    PTR2UV(SvANY(loader)), name);
3157                     tryname = SvPVX(namesv);
3158                     tryrsfp = 0;
3159
3160                     ENTER;
3161                     SAVETMPS;
3162                     EXTEND(SP, 2);
3163
3164                     PUSHMARK(SP);
3165                     PUSHs(dirsv);
3166                     PUSHs(sv);
3167                     PUTBACK;
3168                     if (sv_isobject(loader))
3169                         count = call_method("INC", G_ARRAY);
3170                     else
3171                         count = call_sv(loader, G_ARRAY);
3172                     SPAGAIN;
3173
3174                     if (count > 0) {
3175                         int i = 0;
3176                         SV *arg;
3177
3178                         SP -= count - 1;
3179                         arg = SP[i++];
3180
3181                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3182                             arg = SvRV(arg);
3183                         }
3184
3185                         if (SvTYPE(arg) == SVt_PVGV) {
3186                             IO *io = GvIO((GV *)arg);
3187
3188                             ++filter_has_file;
3189
3190                             if (io) {
3191                                 tryrsfp = IoIFP(io);
3192                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3193                                     /* reading from a child process doesn't
3194                                        nest -- when returning from reading
3195                                        the inner module, the outer one is
3196                                        unreadable (closed?)  I've tried to
3197                                        save the gv to manage the lifespan of
3198                                        the pipe, but this didn't help. XXX */
3199                                     filter_child_proc = (GV *)arg;
3200                                     (void)SvREFCNT_inc(filter_child_proc);
3201                                 }
3202                                 else {
3203                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3204                                         PerlIO_close(IoOFP(io));
3205                                     }
3206                                     IoIFP(io) = Nullfp;
3207                                     IoOFP(io) = Nullfp;
3208                                 }
3209                             }
3210
3211                             if (i < count) {
3212                                 arg = SP[i++];
3213                             }
3214                         }
3215
3216                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3217                             filter_sub = arg;
3218                             (void)SvREFCNT_inc(filter_sub);
3219
3220                             if (i < count) {
3221                                 filter_state = SP[i];
3222                                 (void)SvREFCNT_inc(filter_state);
3223                             }
3224
3225                             if (tryrsfp == 0) {
3226                                 tryrsfp = PerlIO_open("/dev/null",
3227                                                       PERL_SCRIPT_MODE);
3228                             }
3229                         }
3230                     }
3231
3232                     PUTBACK;
3233                     FREETMPS;
3234                     LEAVE;
3235
3236                     if (tryrsfp) {
3237                         break;
3238                     }
3239
3240                     filter_has_file = 0;
3241                     if (filter_child_proc) {
3242                         SvREFCNT_dec(filter_child_proc);
3243                         filter_child_proc = 0;
3244                     }
3245                     if (filter_state) {
3246                         SvREFCNT_dec(filter_state);
3247                         filter_state = 0;
3248                     }
3249                     if (filter_sub) {
3250                         SvREFCNT_dec(filter_sub);
3251                         filter_sub = 0;
3252                     }
3253                 }
3254                 else {
3255                     char *dir = SvPVx(dirsv, n_a);
3256 #ifdef MACOS_TRADITIONAL
3257                     char buf[256];
3258                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3259 #else
3260 #ifdef VMS
3261                     char *unixdir;
3262                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3263                         continue;
3264                     sv_setpv(namesv, unixdir);
3265                     sv_catpv(namesv, unixname);
3266 #else
3267                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3268 #endif
3269 #endif
3270                     TAINT_PROPER("require");
3271                     tryname = SvPVX(namesv);
3272 #ifdef MACOS_TRADITIONAL
3273                     {
3274                         /* Convert slashes in the name part, but not the directory part, to colons */
3275                         char * colon;
3276                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3277                             *colon++ = ':';
3278                     }
3279 #endif
3280                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3281                     if (tryrsfp) {
3282                         if (tryname[0] == '.' && tryname[1] == '/')
3283                             tryname += 2;
3284                         break;
3285                     }
3286                 }
3287             }
3288         }
3289     }
3290     SAVECOPFILE_FREE(&PL_compiling);
3291     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3292     SvREFCNT_dec(namesv);
3293     if (!tryrsfp) {
3294         if (PL_op->op_type == OP_REQUIRE) {
3295             char *msgstr = name;
3296             if (namesv) {                       /* did we lookup @INC? */
3297                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3298                 SV *dirmsgsv = NEWSV(0, 0);
3299                 AV *ar = GvAVn(PL_incgv);
3300                 I32 i;
3301                 sv_catpvn(msg, " in @INC", 8);
3302                 if (instr(SvPVX(msg), ".h "))
3303                     sv_catpv(msg, " (change .h to .ph maybe?)");
3304                 if (instr(SvPVX(msg), ".ph "))
3305                     sv_catpv(msg, " (did you run h2ph?)");
3306                 sv_catpv(msg, " (@INC contains:");
3307                 for (i = 0; i <= AvFILL(ar); i++) {
3308                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3309                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3310                     sv_catsv(msg, dirmsgsv);
3311                 }
3312                 sv_catpvn(msg, ")", 1);
3313                 SvREFCNT_dec(dirmsgsv);
3314                 msgstr = SvPV_nolen(msg);
3315             }
3316             DIE(aTHX_ "Can't locate %s", msgstr);
3317         }
3318
3319         RETPUSHUNDEF;
3320     }
3321     else
3322         SETERRNO(0, SS$_NORMAL);
3323
3324     /* Assume success here to prevent recursive requirement. */
3325     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3326                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3327
3328     ENTER;
3329     SAVETMPS;
3330     lex_start(sv_2mortal(newSVpvn("",0)));
3331     SAVEGENERICSV(PL_rsfp_filters);
3332     PL_rsfp_filters = Nullav;
3333
3334     PL_rsfp = tryrsfp;
3335     SAVEHINTS();
3336     PL_hints = 0;
3337     SAVESPTR(PL_compiling.cop_warnings);
3338     if (PL_dowarn & G_WARN_ALL_ON)
3339         PL_compiling.cop_warnings = pWARN_ALL ;
3340     else if (PL_dowarn & G_WARN_ALL_OFF)
3341         PL_compiling.cop_warnings = pWARN_NONE ;
3342     else
3343         PL_compiling.cop_warnings = pWARN_STD ;
3344     SAVESPTR(PL_compiling.cop_io);
3345     PL_compiling.cop_io = Nullsv;
3346
3347     if (filter_sub || filter_child_proc) {
3348         SV *datasv = filter_add(run_user_filter, Nullsv);
3349         IoLINES(datasv) = filter_has_file;
3350         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3351         IoTOP_GV(datasv) = (GV *)filter_state;
3352         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3353     }
3354
3355     /* switch to eval mode */
3356     push_return(PL_op->op_next);
3357     PUSHBLOCK(cx, CXt_EVAL, SP);
3358     PUSHEVAL(cx, name, Nullgv);
3359
3360     SAVECOPLINE(&PL_compiling);
3361     CopLINE_set(&PL_compiling, 0);
3362
3363     PUTBACK;
3364 #ifdef USE_THREADS
3365     MUTEX_LOCK(&PL_eval_mutex);
3366     if (PL_eval_owner && PL_eval_owner != thr)
3367         while (PL_eval_owner)
3368             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3369     PL_eval_owner = thr;
3370     MUTEX_UNLOCK(&PL_eval_mutex);
3371 #endif /* USE_THREADS */
3372     return DOCATCH(doeval(gimme, NULL));
3373 }
3374
3375 PP(pp_dofile)
3376 {
3377     return pp_require();
3378 }
3379
3380 PP(pp_entereval)
3381 {
3382     dSP;
3383     register PERL_CONTEXT *cx;
3384     dPOPss;
3385     I32 gimme = GIMME_V, was = PL_sub_generation;
3386     char tbuf[TYPE_DIGITS(long) + 12];
3387     char *tmpbuf = tbuf;
3388     char *safestr;
3389     STRLEN len;
3390     OP *ret;
3391
3392     if (!SvPV(sv,len) || !len)
3393         RETPUSHUNDEF;
3394     TAINT_PROPER("eval");
3395
3396     ENTER;
3397     lex_start(sv);
3398     SAVETMPS;
3399
3400     /* switch to eval mode */
3401
3402     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3403         SV *sv = sv_newmortal();
3404         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3405                        (unsigned long)++PL_evalseq,
3406                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3407         tmpbuf = SvPVX(sv);
3408     }
3409     else
3410         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3411     SAVECOPFILE_FREE(&PL_compiling);
3412     CopFILE_set(&PL_compiling, tmpbuf+2);
3413     SAVECOPLINE(&PL_compiling);
3414     CopLINE_set(&PL_compiling, 1);
3415     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3416        deleting the eval's FILEGV from the stash before gv_check() runs
3417        (i.e. before run-time proper). To work around the coredump that
3418        ensues, we always turn GvMULTI_on for any globals that were
3419        introduced within evals. See force_ident(). GSAR 96-10-12 */
3420     safestr = savepv(tmpbuf);
3421     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3422     SAVEHINTS();
3423     PL_hints = PL_op->op_targ;
3424     SAVESPTR(PL_compiling.cop_warnings);
3425     if (specialWARN(PL_curcop->cop_warnings))
3426         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3427     else {
3428         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3429         SAVEFREESV(PL_compiling.cop_warnings);
3430     }
3431     SAVESPTR(PL_compiling.cop_io);
3432     if (specialCopIO(PL_curcop->cop_io))
3433         PL_compiling.cop_io = PL_curcop->cop_io;
3434     else {
3435         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3436         SAVEFREESV(PL_compiling.cop_io);
3437     }
3438
3439     push_return(PL_op->op_next);
3440     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3441     PUSHEVAL(cx, 0, Nullgv);
3442
3443     /* prepare to compile string */
3444
3445     if (PERLDB_LINE && PL_curstash != PL_debstash)
3446         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3447     PUTBACK;
3448 #ifdef USE_THREADS
3449     MUTEX_LOCK(&PL_eval_mutex);
3450     if (PL_eval_owner && PL_eval_owner != thr)
3451         while (PL_eval_owner)
3452             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3453     PL_eval_owner = thr;
3454     MUTEX_UNLOCK(&PL_eval_mutex);
3455 #endif /* USE_THREADS */
3456     ret = doeval(gimme, NULL);
3457     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3458         && ret != PL_op->op_next) {     /* Successive compilation. */
3459         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3460     }
3461     return DOCATCH(ret);
3462 }
3463
3464 PP(pp_leaveeval)
3465 {
3466     dSP;
3467     register SV **mark;
3468     SV **newsp;
3469     PMOP *newpm;
3470     I32 gimme;
3471     register PERL_CONTEXT *cx;
3472     OP *retop;
3473     U8 save_flags = PL_op -> op_flags;
3474     I32 optype;
3475
3476     POPBLOCK(cx,newpm);
3477     POPEVAL(cx);
3478     retop = pop_return();
3479
3480     TAINT_NOT;
3481     if (gimme == G_VOID)
3482         MARK = newsp;
3483     else if (gimme == G_SCALAR) {
3484         MARK = newsp + 1;
3485         if (MARK <= SP) {
3486             if (SvFLAGS(TOPs) & SVs_TEMP)
3487                 *MARK = TOPs;
3488             else
3489                 *MARK = sv_mortalcopy(TOPs);
3490         }
3491         else {
3492             MEXTEND(mark,0);
3493             *MARK = &PL_sv_undef;
3494         }
3495         SP = MARK;
3496     }
3497     else {
3498         /* in case LEAVE wipes old return values */
3499         for (mark = newsp + 1; mark <= SP; mark++) {
3500             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3501                 *mark = sv_mortalcopy(*mark);
3502                 TAINT_NOT;      /* Each item is independent */
3503             }
3504         }
3505     }
3506     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3507
3508 #ifdef DEBUGGING
3509     assert(CvDEPTH(PL_compcv) == 1);
3510 #endif
3511     CvDEPTH(PL_compcv) = 0;
3512     lex_end();
3513
3514     if (optype == OP_REQUIRE &&
3515         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3516     {
3517         /* Unassume the success we assumed earlier. */
3518         SV *nsv = cx->blk_eval.old_namesv;
3519         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3520         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3521         /* die_where() did LEAVE, or we won't be here */
3522     }
3523     else {
3524         LEAVE;
3525         if (!(save_flags & OPf_SPECIAL))
3526             sv_setpv(ERRSV,"");
3527     }
3528
3529     RETURNOP(retop);
3530 }
3531
3532 PP(pp_entertry)
3533 {
3534     dSP;
3535     register PERL_CONTEXT *cx;
3536     I32 gimme = GIMME_V;
3537
3538     ENTER;
3539     SAVETMPS;
3540
3541     push_return(cLOGOP->op_other->op_next);
3542     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3543     PUSHEVAL(cx, 0, 0);
3544
3545     PL_in_eval = EVAL_INEVAL;
3546     sv_setpv(ERRSV,"");
3547     PUTBACK;
3548     return DOCATCH(PL_op->op_next);
3549 }
3550
3551 PP(pp_leavetry)
3552 {
3553     dSP;
3554     register SV **mark;
3555     SV **newsp;
3556     PMOP *newpm;
3557     I32 gimme;
3558     register PERL_CONTEXT *cx;
3559     I32 optype;
3560
3561     POPBLOCK(cx,newpm);
3562     POPEVAL(cx);
3563     pop_return();
3564
3565     TAINT_NOT;
3566     if (gimme == G_VOID)
3567         SP = newsp;
3568     else if (gimme == G_SCALAR) {
3569         MARK = newsp + 1;
3570         if (MARK <= SP) {
3571             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3572                 *MARK = TOPs;
3573             else
3574                 *MARK = sv_mortalcopy(TOPs);
3575         }
3576         else {
3577             MEXTEND(mark,0);
3578             *MARK = &PL_sv_undef;
3579         }
3580         SP = MARK;
3581     }
3582     else {
3583         /* in case LEAVE wipes old return values */
3584         for (mark = newsp + 1; mark <= SP; mark++) {
3585             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3586                 *mark = sv_mortalcopy(*mark);
3587                 TAINT_NOT;      /* Each item is independent */
3588             }
3589         }
3590     }
3591     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3592
3593     LEAVE;
3594     sv_setpv(ERRSV,"");
3595     RETURN;
3596 }
3597
3598 STATIC void
3599 S_doparseform(pTHX_ SV *sv)
3600 {
3601     STRLEN len;
3602     register char *s = SvPV_force(sv, len);
3603     register char *send = s + len;
3604     register char *base = Nullch;
3605     register I32 skipspaces = 0;
3606     bool noblank   = FALSE;
3607     bool repeat    = FALSE;
3608     bool postspace = FALSE;
3609     U16 *fops;
3610     register U16 *fpc;
3611     U16 *linepc = 0;
3612     register I32 arg;
3613     bool ischop;
3614
3615     if (len == 0)
3616         Perl_croak(aTHX_ "Null picture in formline");
3617
3618     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3619     fpc = fops;
3620
3621     if (s < send) {
3622         linepc = fpc;
3623         *fpc++ = FF_LINEMARK;
3624         noblank = repeat = FALSE;
3625         base = s;
3626     }
3627
3628     while (s <= send) {
3629         switch (*s++) {
3630         default:
3631             skipspaces = 0;
3632             continue;
3633
3634         case '~':
3635             if (*s == '~') {
3636                 repeat = TRUE;
3637                 *s = ' ';
3638             }
3639             noblank = TRUE;
3640             s[-1] = ' ';
3641             /* FALL THROUGH */
3642         case ' ': case '\t':
3643             skipspaces++;
3644             continue;
3645
3646         case '\n': case 0:
3647             arg = s - base;
3648             skipspaces++;
3649             arg -= skipspaces;
3650             if (arg) {
3651                 if (postspace)
3652                     *fpc++ = FF_SPACE;
3653                 *fpc++ = FF_LITERAL;
3654                 *fpc++ = arg;
3655             }
3656             postspace = FALSE;
3657             if (s <= send)
3658                 skipspaces--;
3659             if (skipspaces) {
3660                 *fpc++ = FF_SKIP;
3661                 *fpc++ = skipspaces;
3662             }
3663             skipspaces = 0;
3664             if (s <= send)
3665                 *fpc++ = FF_NEWLINE;
3666             if (noblank) {
3667                 *fpc++ = FF_BLANK;
3668                 if (repeat)
3669                     arg = fpc - linepc + 1;
3670                 else
3671                     arg = 0;
3672                 *fpc++ = arg;
3673             }
3674             if (s < send) {
3675                 linepc = fpc;
3676                 *fpc++ = FF_LINEMARK;
3677                 noblank = repeat = FALSE;
3678                 base = s;
3679             }
3680             else
3681                 s++;
3682             continue;
3683
3684         case '@':
3685         case '^':
3686             ischop = s[-1] == '^';
3687
3688             if (postspace) {
3689                 *fpc++ = FF_SPACE;
3690                 postspace = FALSE;
3691             }
3692             arg = (s - base) - 1;
3693             if (arg) {
3694                 *fpc++ = FF_LITERAL;
3695                 *fpc++ = arg;
3696             }
3697
3698             base = s - 1;
3699             *fpc++ = FF_FETCH;
3700             if (*s == '*') {
3701                 s++;
3702                 *fpc++ = 0;
3703                 *fpc++ = FF_LINEGLOB;
3704             }
3705             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3706                 arg = ischop ? 512 : 0;
3707                 base = s - 1;
3708                 while (*s == '#')
3709                     s++;
3710                 if (*s == '.') {
3711                     char *f;
3712                     s++;
3713                     f = s;
3714                     while (*s == '#')
3715                         s++;
3716                     arg |= 256 + (s - f);
3717                 }
3718                 *fpc++ = s - base;              /* fieldsize for FETCH */
3719                 *fpc++ = FF_DECIMAL;
3720                 *fpc++ = arg;
3721             }
3722             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3723                 arg = ischop ? 512 : 0;
3724                 base = s - 1;
3725                 s++;                                /* skip the '0' first */
3726                 while (*s == '#')
3727                     s++;
3728                 if (*s == '.') {
3729                     char *f;
3730                     s++;
3731                     f = s;
3732                     while (*s == '#')
3733                         s++;
3734                     arg |= 256 + (s - f);
3735                 }
3736                 *fpc++ = s - base;                /* fieldsize for FETCH */
3737                 *fpc++ = FF_0DECIMAL;
3738                 *fpc++ = arg;
3739             }
3740             else {
3741                 I32 prespace = 0;
3742                 bool ismore = FALSE;
3743
3744                 if (*s == '>') {
3745                     while (*++s == '>') ;
3746                     prespace = FF_SPACE;
3747                 }
3748                 else if (*s == '|') {
3749                     while (*++s == '|') ;
3750                     prespace = FF_HALFSPACE;
3751                     postspace = TRUE;
3752                 }
3753                 else {
3754                     if (*s == '<')
3755                         while (*++s == '<') ;
3756                     postspace = TRUE;
3757                 }
3758                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3759                     s += 3;
3760                     ismore = TRUE;
3761                 }
3762                 *fpc++ = s - base;              /* fieldsize for FETCH */
3763
3764                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3765
3766                 if (prespace)
3767                     *fpc++ = prespace;
3768                 *fpc++ = FF_ITEM;
3769                 if (ismore)
3770                     *fpc++ = FF_MORE;
3771                 if (ischop)
3772                     *fpc++ = FF_CHOP;
3773             }
3774             base = s;
3775             skipspaces = 0;
3776             continue;
3777         }
3778     }
3779     *fpc++ = FF_END;
3780
3781     arg = fpc - fops;
3782     { /* need to jump to the next word */
3783         int z;
3784         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3785         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3786         s = SvPVX(sv) + SvCUR(sv) + z;
3787     }
3788     Copy(fops, s, arg, U16);
3789     Safefree(fops);
3790     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3791     SvCOMPILED_on(sv);
3792 }
3793
3794 /*
3795  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3796  *
3797  * The original code was written in conjunction with BSD Computer Software
3798  * Research Group at University of California, Berkeley.
3799  *
3800  * See also: "Optimistic Merge Sort" (SODA '92)
3801  *
3802  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3803  *
3804  * The code can be distributed under the same terms as Perl itself.
3805  *
3806  */
3807
3808 #ifdef  TESTHARNESS
3809 #include <sys/types.h>
3810 typedef void SV;
3811 #define pTHXo_
3812 #define pTHX_
3813 #define STATIC
3814 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3815 #define Safefree(VAR) free(VAR)
3816 typedef int  (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3817 #endif  /* TESTHARNESS */
3818
3819 typedef char * aptr;            /* pointer for arithmetic on sizes */
3820 typedef SV * gptr;              /* pointers in our lists */
3821
3822 /* Binary merge internal sort, with a few special mods
3823 ** for the special perl environment it now finds itself in.
3824 **
3825 ** Things that were once options have been hotwired
3826 ** to values suitable for this use.  In particular, we'll always
3827 ** initialize looking for natural runs, we'll always produce stable
3828 ** output, and we'll always do Peter McIlroy's binary merge.
3829 */
3830
3831 /* Pointer types for arithmetic and storage and convenience casts */
3832
3833 #define APTR(P) ((aptr)(P))
3834 #define GPTP(P) ((gptr *)(P))
3835 #define GPPP(P) ((gptr **)(P))
3836
3837
3838 /* byte offset from pointer P to (larger) pointer Q */
3839 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3840
3841 #define PSIZE sizeof(gptr)
3842
3843 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3844
3845 #ifdef  PSHIFT
3846 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
3847 #define PNBYTE(N)       ((N) << (PSHIFT))
3848 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
3849 #else
3850 /* Leave optimization to compiler */
3851 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
3852 #define PNBYTE(N)       ((N) * (PSIZE))
3853 #define PINDEX(P, N)    (GPTP(P) + (N))
3854 #endif
3855
3856 /* Pointer into other corresponding to pointer into this */
3857 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3858
3859 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3860
3861
3862 /* Runs are identified by a pointer in the auxilliary list.
3863 ** The pointer is at the start of the list,
3864 ** and it points to the start of the next list.
3865 ** NEXT is used as an lvalue, too.
3866 */
3867
3868 #define NEXT(P)         (*GPPP(P))
3869
3870
3871 /* PTHRESH is the minimum number of pairs with the same sense to justify
3872 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
3873 ** not just elements, so PTHRESH == 8 means a run of 16.
3874 */
3875
3876 #define PTHRESH (8)
3877
3878 /* RTHRESH is the number of elements in a run that must compare low
3879 ** to the low element from the opposing run before we justify
3880 ** doing a binary rampup instead of single stepping.
3881 ** In random input, N in a row low should only happen with
3882 ** probability 2^(1-N), so we can risk that we are dealing
3883 ** with orderly input without paying much when we aren't.
3884 */
3885
3886 #define RTHRESH (6)
3887
3888
3889 /*
3890 ** Overview of algorithm and variables.
3891 ** The array of elements at list1 will be organized into runs of length 2,
3892 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
3893 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3894 **
3895 ** Unless otherwise specified, pair pointers address the first of two elements.
3896 **
3897 ** b and b+1 are a pair that compare with sense ``sense''.
3898 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3899 **
3900 ** p2 parallels b in the list2 array, where runs are defined by
3901 ** a pointer chain.
3902 **
3903 ** t represents the ``top'' of the adjacent pairs that might extend
3904 ** the run beginning at b.  Usually, t addresses a pair
3905 ** that compares with opposite sense from (b,b+1).
3906 ** However, it may also address a singleton element at the end of list1,
3907 ** or it may be equal to ``last'', the first element beyond list1.
3908 **
3909 ** r addresses the Nth pair following b.  If this would be beyond t,
3910 ** we back it off to t.  Only when r is less than t do we consider the
3911 ** run long enough to consider checking.
3912 **
3913 ** q addresses a pair such that the pairs at b through q already form a run.
3914 ** Often, q will equal b, indicating we only are sure of the pair itself.
3915 ** However, a search on the previous cycle may have revealed a longer run,
3916 ** so q may be greater than b.
3917 **
3918 ** p is used to work back from a candidate r, trying to reach q,
3919 ** which would mean b through r would be a run.  If we discover such a run,
3920 ** we start q at r and try to push it further towards t.
3921 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3922 ** In any event, after the check (if any), we have two main cases.
3923 **
3924 ** 1) Short run.  b <= q < p <= r <= t.
3925 **      b through q is a run (perhaps trivial)
3926 **      q through p are uninteresting pairs
3927 **      p through r is a run
3928 **
3929 ** 2) Long run.  b < r <= q < t.
3930 **      b through q is a run (of length >= 2 * PTHRESH)
3931 **
3932 ** Note that degenerate cases are not only possible, but likely.
3933 ** For example, if the pair following b compares with opposite sense,
3934 ** then b == q < p == r == t.
3935 */
3936
3937
3938 static void
3939 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3940 {
3941     int sense;
3942     register gptr *b, *p, *q, *t, *p2;
3943     register gptr c, *last, *r;
3944     gptr *savep;
3945
3946     b = list1;
3947     last = PINDEX(b, nmemb);
3948     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3949     for (p2 = list2; b < last; ) {
3950         /* We just started, or just reversed sense.
3951         ** Set t at end of pairs with the prevailing sense.
3952         */
3953         for (p = b+2, t = p; ++p < last; t = ++p) {
3954             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3955         }
3956         q = b;
3957         /* Having laid out the playing field, look for long runs */
3958         do {
3959             p = r = b + (2 * PTHRESH);
3960             if (r >= t) p = r = t;      /* too short to care about */
3961             else {
3962                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3963                        ((p -= 2) > q));
3964                 if (p <= q) {
3965                     /* b through r is a (long) run.
3966                     ** Extend it as far as possible.
3967                     */
3968                     p = q = r;
3969                     while (((p += 2) < t) &&
3970                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3971                     r = p = q + 2;      /* no simple pairs, no after-run */
3972                 }
3973             }
3974             if (q > b) {                /* run of greater than 2 at b */
3975                 savep = p;
3976                 p = q += 2;
3977                 /* pick up singleton, if possible */
3978                 if ((p == t) &&
3979                     ((t + 1) == last) &&
3980                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3981                     savep = r = p = q = last;
3982                 p2 = NEXT(p2) = p2 + (p - b);
3983                 if (sense) while (b < --p) {
3984                     c = *b;
3985                     *b++ = *p;
3986                     *p = c;
3987                 }
3988                 p = savep;
3989             }
3990             while (q < p) {             /* simple pairs */
3991                 p2 = NEXT(p2) = p2 + 2;
3992                 if (sense) {
3993                     c = *q++;
3994                     *(q-1) = *q;
3995                     *q++ = c;
3996                 } else q += 2;
3997             }
3998             if (((b = p) == t) && ((t+1) == last)) {
3999                 NEXT(p2) = p2 + 1;
4000                 b++;
4001             }
4002             q = r;
4003         } while (b < t);
4004         sense = !sense;
4005     }
4006     return;
4007 }
4008
4009
4010 /* Overview of bmerge variables:
4011 **
4012 ** list1 and list2 address the main and auxiliary arrays.
4013 ** They swap identities after each merge pass.
4014 ** Base points to the original list1, so we can tell if
4015 ** the pointers ended up where they belonged (or must be copied).
4016 **
4017 ** When we are merging two lists, f1 and f2 are the next elements
4018 ** on the respective lists.  l1 and l2 mark the end of the lists.
4019 ** tp2 is the current location in the merged list.
4020 **
4021 ** p1 records where f1 started.
4022 ** After the merge, a new descriptor is built there.
4023 **
4024 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
4025 ** It is used to identify and delimit the runs.
4026 **
4027 ** In the heat of determining where q, the greater of the f1/f2 elements,
4028 ** belongs in the other list, b, t and p, represent bottom, top and probe
4029 ** locations, respectively, in the other list.
4030 ** They make convenient temporary pointers in other places.
4031 */
4032
4033 STATIC void
4034 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
4035 {
4036     int i, run;
4037     int sense;
4038     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
4039     gptr *aux, *list2, *p2, *last;
4040     gptr *base = list1;
4041     gptr *p1;
4042
4043     if (nmemb <= 1) return;     /* sorted trivially */
4044     New(799,list2,nmemb,gptr);  /* allocate auxilliary array */
4045     aux = list2;
4046     dynprep(aTHX_ list1, list2, nmemb, cmp);
4047     last = PINDEX(list2, nmemb);
4048     while (NEXT(list2) != last) {
4049         /* More than one run remains.  Do some merging to reduce runs. */
4050         l2 = p1 = list1;
4051         for (tp2 = p2 = list2; p2 != last;) {
4052             /* The new first run begins where the old second list ended.
4053             ** Use the p2 ``parallel'' pointer to identify the end of the run.
4054             */
4055             f1 = l2;
4056             t = NEXT(p2);
4057             f2 = l1 = POTHER(t, list2, list1);
4058             if (t != last) t = NEXT(t);
4059             l2 = POTHER(t, list2, list1);
4060             p2 = t;
4061             while (f1 < l1 && f2 < l2) {
4062                 /* If head 1 is larger than head 2, find ALL the elements
4063                 ** in list 2 strictly less than head1, write them all,
4064                 ** then head 1.  Then compare the new heads, and repeat,
4065                 ** until one or both lists are exhausted.
4066                 **
4067                 ** In all comparisons (after establishing
4068                 ** which head to merge) the item to merge
4069                 ** (at pointer q) is the first operand of
4070                 ** the comparison.  When we want to know
4071                 ** if ``q is strictly less than the other'',
4072                 ** we can't just do
4073                 **    cmp(q, other) < 0
4074                 ** because stability demands that we treat equality
4075                 ** as high when q comes from l2, and as low when
4076                 ** q was from l1.  So we ask the question by doing
4077                 **    cmp(q, other) <= sense
4078                 ** and make sense == 0 when equality should look low,
4079                 ** and -1 when equality should look high.
4080                 */
4081
4082
4083                 if (cmp(aTHX_ *f1, *f2) <= 0) {
4084                     q = f2; b = f1; t = l1;
4085                     sense = -1;
4086                 } else {
4087                     q = f1; b = f2; t = l2;
4088                     sense = 0;
4089                 }
4090
4091
4092                 /* ramp up
4093                 **
4094                 ** Leave t at something strictly
4095                 ** greater than q (or at the end of the list),
4096                 ** and b at something strictly less than q.
4097                 */
4098                 for (i = 1, run = 0 ;;) {
4099                     if ((p = PINDEX(b, i)) >= t) {
4100                         /* off the end */
4101                         if (((p = PINDEX(t, -1)) > b) &&
4102                             (cmp(aTHX_ *q, *p) <= sense))
4103                              t = p;
4104                         else b = p;
4105                         break;
4106                     } else if (cmp(aTHX_ *q, *p) <= sense) {
4107                         t = p;
4108                         break;
4109                     } else b = p;
4110                     if (++run >= RTHRESH) i += i;
4111                 }
4112
4113
4114                 /* q is known to follow b and must be inserted before t.
4115                 ** Increment b, so the range of possibilities is [b,t).
4116                 ** Round binary split down, to favor early appearance.
4117                 ** Adjust b and t until q belongs just before t.
4118                 */
4119
4120                 b++;
4121                 while (b < t) {
4122                     p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4123                     if (cmp(aTHX_ *q, *p) <= sense) {
4124                         t = p;
4125                     } else b = p + 1;
4126                 }
4127
4128
4129                 /* Copy all the strictly low elements */
4130
4131                 if (q == f1) {
4132                     FROMTOUPTO(f2, tp2, t);
4133                     *tp2++ = *f1++;
4134                 } else {
4135                     FROMTOUPTO(f1, tp2, t);
4136                     *tp2++ = *f2++;
4137                 }
4138             }
4139
4140
4141             /* Run out remaining list */
4142             if (f1 == l1) {
4143                    if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4144             } else              FROMTOUPTO(f1, tp2, l1);
4145             p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4146         }
4147         t = list1;
4148         list1 = list2;
4149         list2 = t;
4150         last = PINDEX(list2, nmemb);
4151     }
4152     if (base == list2) {
4153         last = PINDEX(list1, nmemb);
4154         FROMTOUPTO(list1, list2, last);
4155     }
4156     Safefree(aux);
4157     return;
4158 }
4159
4160
4161 #ifdef PERL_OBJECT
4162 #undef this
4163 #define this pPerl
4164 #include "XSUB.h"
4165 #endif
4166
4167
4168 static I32
4169 sortcv(pTHXo_ SV *a, SV *b)
4170 {
4171     I32 oldsaveix = PL_savestack_ix;
4172     I32 oldscopeix = PL_scopestack_ix;
4173     I32 result;
4174     GvSV(PL_firstgv) = a;
4175     GvSV(PL_secondgv) = b;
4176     PL_stack_sp = PL_stack_base;
4177     PL_op = PL_sortcop;
4178     CALLRUNOPS(aTHX);
4179     if (PL_stack_sp != PL_stack_base + 1)
4180         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4181     if (!SvNIOKp(*PL_stack_sp))
4182         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4183     result = SvIV(*PL_stack_sp);
4184     while (PL_scopestack_ix > oldscopeix) {
4185         LEAVE;
4186     }
4187     leave_scope(oldsaveix);
4188     return result;
4189 }
4190
4191 static I32
4192 sortcv_stacked(pTHXo_ SV *a, SV *b)
4193 {
4194     I32 oldsaveix = PL_savestack_ix;
4195     I32 oldscopeix = PL_scopestack_ix;
4196     I32 result;
4197     AV *av;
4198
4199 #ifdef USE_THREADS
4200     av = (AV*)PL_curpad[0];
4201 #else
4202     av = GvAV(PL_defgv);
4203 #endif
4204
4205     if (AvMAX(av) < 1) {
4206         SV** ary = AvALLOC(av);
4207         if (AvARRAY(av) != ary) {
4208             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4209             SvPVX(av) = (char*)ary;
4210         }
4211         if (AvMAX(av) < 1) {
4212             AvMAX(av) = 1;
4213             Renew(ary,2,SV*);
4214             SvPVX(av) = (char*)ary;
4215         }
4216     }
4217     AvFILLp(av) = 1;
4218
4219     AvARRAY(av)[0] = a;
4220     AvARRAY(av)[1] = b;
4221     PL_stack_sp = PL_stack_base;
4222     PL_op = PL_sortcop;
4223     CALLRUNOPS(aTHX);
4224     if (PL_stack_sp != PL_stack_base + 1)
4225         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4226     if (!SvNIOKp(*PL_stack_sp))
4227         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4228     result = SvIV(*PL_stack_sp);
4229     while (PL_scopestack_ix > oldscopeix) {
4230         LEAVE;
4231     }
4232     leave_scope(oldsaveix);
4233     return result;
4234 }
4235
4236 static I32
4237 sortcv_xsub(pTHXo_ SV *a, SV *b)
4238 {
4239     dSP;
4240     I32 oldsaveix = PL_savestack_ix;
4241     I32 oldscopeix = PL_scopestack_ix;
4242     I32 result;
4243     CV *cv=(CV*)PL_sortcop;
4244
4245     SP = PL_stack_base;
4246     PUSHMARK(SP);
4247     EXTEND(SP, 2);
4248     *++SP = a;
4249     *++SP = b;
4250     PUTBACK;
4251     (void)(*CvXSUB(cv))(aTHXo_ cv);
4252     if (PL_stack_sp != PL_stack_base + 1)
4253         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4254     if (!SvNIOKp(*PL_stack_sp))
4255         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4256     result = SvIV(*PL_stack_sp);
4257     while (PL_scopestack_ix > oldscopeix) {
4258         LEAVE;
4259     }
4260     leave_scope(oldsaveix);
4261     return result;
4262 }
4263
4264
4265 static I32
4266 sv_ncmp(pTHXo_ SV *a, SV *b)
4267 {
4268     NV nv1 = SvNV(a);
4269     NV nv2 = SvNV(b);
4270     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4271 }
4272
4273 static I32
4274 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4275 {
4276     IV iv1 = SvIV(a);
4277     IV iv2 = SvIV(b);
4278     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4279 }
4280 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4281           *svp = Nullsv;                                \
4282           if (PL_amagic_generation) { \
4283             if (SvAMAGIC(left)||SvAMAGIC(right))\
4284                 *svp = amagic_call(left, \
4285                                    right, \
4286                                    CAT2(meth,_amg), \
4287                                    0); \
4288           } \
4289         } STMT_END
4290
4291 static I32
4292 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4293 {
4294     SV *tmpsv;
4295     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4296     if (tmpsv) {
4297         NV d;
4298
4299         if (SvIOK(tmpsv)) {
4300             I32 i = SvIVX(tmpsv);
4301             if (i > 0)
4302                return 1;
4303             return i? -1 : 0;
4304         }
4305         d = SvNV(tmpsv);
4306         if (d > 0)
4307            return 1;
4308         return d? -1 : 0;
4309      }
4310      return sv_ncmp(aTHXo_ a, b);
4311 }
4312
4313 static I32
4314 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4315 {
4316     SV *tmpsv;
4317     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4318     if (tmpsv) {
4319         NV d;
4320
4321         if (SvIOK(tmpsv)) {
4322             I32 i = SvIVX(tmpsv);
4323             if (i > 0)
4324                return 1;
4325             return i? -1 : 0;
4326         }
4327         d = SvNV(tmpsv);
4328         if (d > 0)
4329            return 1;
4330         return d? -1 : 0;
4331     }
4332     return sv_i_ncmp(aTHXo_ a, b);
4333 }
4334
4335 static I32
4336 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4337 {
4338     SV *tmpsv;
4339     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4340     if (tmpsv) {
4341         NV d;
4342
4343         if (SvIOK(tmpsv)) {
4344             I32 i = SvIVX(tmpsv);
4345             if (i > 0)
4346                return 1;
4347             return i? -1 : 0;
4348         }
4349         d = SvNV(tmpsv);
4350         if (d > 0)
4351            return 1;
4352         return d? -1 : 0;
4353     }
4354     return sv_cmp(str1, str2);
4355 }
4356
4357 static I32
4358 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4359 {
4360     SV *tmpsv;
4361     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4362     if (tmpsv) {
4363         NV d;
4364
4365         if (SvIOK(tmpsv)) {
4366             I32 i = SvIVX(tmpsv);
4367             if (i > 0)
4368                return 1;
4369             return i? -1 : 0;
4370         }
4371         d = SvNV(tmpsv);
4372         if (d > 0)
4373            return 1;
4374         return d? -1 : 0;
4375     }
4376     return sv_cmp_locale(str1, str2);
4377 }
4378
4379 static I32
4380 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4381 {
4382     SV *datasv = FILTER_DATA(idx);
4383     int filter_has_file = IoLINES(datasv);
4384     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4385     SV *filter_state = (SV *)IoTOP_GV(datasv);
4386     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4387     int len = 0;
4388
4389     /* I was having segfault trouble under Linux 2.2.5 after a
4390        parse error occured.  (Had to hack around it with a test
4391        for PL_error_count == 0.)  Solaris doesn't segfault --
4392        not sure where the trouble is yet.  XXX */
4393
4394     if (filter_has_file) {
4395         len = FILTER_READ(idx+1, buf_sv, maxlen);
4396     }
4397
4398     if (filter_sub && len >= 0) {
4399         dSP;
4400         int count;
4401
4402         ENTER;
4403         SAVE_DEFSV;
4404         SAVETMPS;
4405         EXTEND(SP, 2);
4406
4407         DEFSV = buf_sv;
4408         PUSHMARK(SP);
4409         PUSHs(sv_2mortal(newSViv(maxlen)));
4410         if (filter_state) {
4411             PUSHs(filter_state);
4412         }
4413         PUTBACK;
4414         count = call_sv(filter_sub, G_SCALAR);
4415         SPAGAIN;
4416
4417         if (count > 0) {
4418             SV *out = POPs;
4419             if (SvOK(out)) {
4420                 len = SvIV(out);
4421             }
4422         }
4423
4424         PUTBACK;
4425         FREETMPS;
4426         LEAVE;
4427     }
4428
4429     if (len <= 0) {
4430         IoLINES(datasv) = 0;
4431         if (filter_child_proc) {
4432             SvREFCNT_dec(filter_child_proc);
4433             IoFMT_GV(datasv) = Nullgv;
4434         }
4435         if (filter_state) {
4436             SvREFCNT_dec(filter_state);
4437             IoTOP_GV(datasv) = Nullgv;
4438         }
4439         if (filter_sub) {
4440             SvREFCNT_dec(filter_sub);
4441             IoBOTTOM_GV(datasv) = Nullgv;
4442         }
4443         filter_del(run_user_filter);
4444     }
4445
4446     return len;
4447 }
4448
4449 #ifdef PERL_OBJECT
4450
4451 static I32
4452 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4453 {
4454     return sv_cmp_locale(str1, str2);
4455 }
4456
4457 static I32
4458 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4459 {
4460     return sv_cmp(str1, str2);
4461 }
4462
4463 #endif /* PERL_OBJECT */