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