pp_ctl.c

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