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