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