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