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