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