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