pp_ctl.c

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