pp_ctl.c

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