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 = ((saveop && saveop->op_type == OP_REQUIRE)
2732                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2733                   : EVAL_INEVAL);
2734
2735     PUSHMARK(SP);
2736
2737     /* set up a scratch pad */
2738
2739     SAVEI32(PL_padix);
2740     SAVEVPTR(PL_curpad);
2741     SAVESPTR(PL_comppad);
2742     SAVESPTR(PL_comppad_name);
2743     SAVEI32(PL_comppad_name_fill);
2744     SAVEI32(PL_min_intro_pending);
2745     SAVEI32(PL_max_intro_pending);
2746
2747     caller = PL_compcv;
2748     for (i = cxstack_ix - 1; i >= 0; i--) {
2749         PERL_CONTEXT *cx = &cxstack[i];
2750         if (CxTYPE(cx) == CXt_EVAL)
2751             break;
2752         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2753             caller = cx->blk_sub.cv;
2754             break;
2755         }
2756     }
2757
2758     SAVESPTR(PL_compcv);
2759     PL_compcv = (CV*)NEWSV(1104,0);
2760     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2761     CvEVAL_on(PL_compcv);
2762 #ifdef USE_THREADS
2763     CvOWNER(PL_compcv) = 0;
2764     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2765     MUTEX_INIT(CvMUTEXP(PL_compcv));
2766 #endif /* USE_THREADS */
2767
2768     PL_comppad = newAV();
2769     av_push(PL_comppad, Nullsv);
2770     PL_curpad = AvARRAY(PL_comppad);
2771     PL_comppad_name = newAV();
2772     PL_comppad_name_fill = 0;
2773     PL_min_intro_pending = 0;
2774     PL_padix = 0;
2775 #ifdef USE_THREADS
2776     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2777     PL_curpad[0] = (SV*)newAV();
2778     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2779 #endif /* USE_THREADS */
2780
2781     comppadlist = newAV();
2782     AvREAL_off(comppadlist);
2783     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2784     av_store(comppadlist, 1, (SV*)PL_comppad);
2785     CvPADLIST(PL_compcv) = comppadlist;
2786
2787     if (!saveop ||
2788         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2789     {
2790         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2791     }
2792
2793     SAVEFREESV(PL_compcv);
2794
2795     /* make sure we compile in the right package */
2796
2797     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2798         SAVESPTR(PL_curstash);
2799         PL_curstash = CopSTASH(PL_curcop);
2800     }
2801     SAVESPTR(PL_beginav);
2802     PL_beginav = newAV();
2803     SAVEFREESV(PL_beginav);
2804     SAVEI32(PL_error_count);
2805
2806     /* try to compile it */
2807
2808     PL_eval_root = Nullop;
2809     PL_error_count = 0;
2810     PL_curcop = &PL_compiling;
2811     PL_curcop->cop_arybase = 0;
2812     SvREFCNT_dec(PL_rs);
2813     PL_rs = newSVpvn("\n", 1);
2814     if (saveop && saveop->op_flags & OPf_SPECIAL)
2815         PL_in_eval |= EVAL_KEEPERR;
2816     else
2817         sv_setpv(ERRSV,"");
2818     if (yyparse() || PL_error_count || !PL_eval_root) {
2819         SV **newsp;
2820         I32 gimme;
2821         PERL_CONTEXT *cx;
2822         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2823         STRLEN n_a;
2824
2825         PL_op = saveop;
2826         if (PL_eval_root) {
2827             op_free(PL_eval_root);
2828             PL_eval_root = Nullop;
2829         }
2830         SP = PL_stack_base + POPMARK;           /* pop original mark */
2831         if (!startop) {
2832             POPBLOCK(cx,PL_curpm);
2833             POPEVAL(cx);
2834             pop_return();
2835         }
2836         lex_end();
2837         LEAVE;
2838         if (optype == OP_REQUIRE) {
2839             char* msg = SvPVx(ERRSV, n_a);
2840             DIE(aTHX_ "%sCompilation failed in require",
2841                 *msg ? msg : "Unknown error\n");
2842         }
2843         else if (startop) {
2844             char* msg = SvPVx(ERRSV, n_a);
2845
2846             POPBLOCK(cx,PL_curpm);
2847             POPEVAL(cx);
2848             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2849                        (*msg ? msg : "Unknown error\n"));
2850         }
2851         SvREFCNT_dec(PL_rs);
2852         PL_rs = SvREFCNT_inc(PL_nrs);
2853 #ifdef USE_THREADS
2854         MUTEX_LOCK(&PL_eval_mutex);
2855         PL_eval_owner = 0;
2856         COND_SIGNAL(&PL_eval_cond);
2857         MUTEX_UNLOCK(&PL_eval_mutex);
2858 #endif /* USE_THREADS */
2859         RETPUSHUNDEF;
2860     }
2861     SvREFCNT_dec(PL_rs);
2862     PL_rs = SvREFCNT_inc(PL_nrs);
2863     CopLINE_set(&PL_compiling, 0);
2864     if (startop) {
2865         *startop = PL_eval_root;
2866         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2867         CvOUTSIDE(PL_compcv) = Nullcv;
2868     } else
2869         SAVEFREEOP(PL_eval_root);
2870     if (gimme & G_VOID)
2871         scalarvoid(PL_eval_root);
2872     else if (gimme & G_ARRAY)
2873         list(PL_eval_root);
2874     else
2875         scalar(PL_eval_root);
2876
2877     DEBUG_x(dump_eval());
2878
2879     /* Register with debugger: */
2880     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2881         CV *cv = get_cv("DB::postponed", FALSE);
2882         if (cv) {
2883             dSP;
2884             PUSHMARK(SP);
2885             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2886             PUTBACK;
2887             call_sv((SV*)cv, G_DISCARD);
2888         }
2889     }
2890
2891     /* compiled okay, so do it */
2892
2893     CvDEPTH(PL_compcv) = 1;
2894     SP = PL_stack_base + POPMARK;               /* pop original mark */
2895     PL_op = saveop;                     /* The caller may need it. */
2896     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2897 #ifdef USE_THREADS
2898     MUTEX_LOCK(&PL_eval_mutex);
2899     PL_eval_owner = 0;
2900     COND_SIGNAL(&PL_eval_cond);
2901     MUTEX_UNLOCK(&PL_eval_mutex);
2902 #endif /* USE_THREADS */
2903
2904     RETURNOP(PL_eval_start);
2905 }
2906
2907 STATIC PerlIO *
2908 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2909 {
2910     STRLEN namelen = strlen(name);
2911     PerlIO *fp;
2912
2913     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2914         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2915         char *pmc = SvPV_nolen(pmcsv);
2916         Stat_t pmstat;
2917         Stat_t pmcstat;
2918         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2919             fp = PerlIO_open(name, mode);
2920         }
2921         else {
2922             if (PerlLIO_stat(name, &pmstat) < 0 ||
2923                 pmstat.st_mtime < pmcstat.st_mtime)
2924             {
2925                 fp = PerlIO_open(pmc, mode);
2926             }
2927             else {
2928                 fp = PerlIO_open(name, mode);
2929             }
2930         }
2931         SvREFCNT_dec(pmcsv);
2932     }
2933     else {
2934         fp = PerlIO_open(name, mode);
2935     }
2936     return fp;
2937 }
2938
2939 PP(pp_require)
2940 {
2941     djSP;
2942     register PERL_CONTEXT *cx;
2943     SV *sv;
2944     char *name;
2945     STRLEN len;
2946     char *tryname;
2947     SV *namesv = Nullsv;
2948     SV** svp;
2949     I32 gimme = G_SCALAR;
2950     PerlIO *tryrsfp = 0;
2951     STRLEN n_a;
2952     int filter_has_file = 0;
2953     GV *filter_child_proc = 0;
2954     SV *filter_state = 0;
2955     SV *filter_sub = 0;
2956
2957     sv = POPs;
2958     if (SvNIOKp(sv)) {
2959         if (SvPOK(sv) && SvNOK(sv)) {           /* require v5.6.1 */
2960             UV rev = 0, ver = 0, sver = 0;
2961             I32 len;
2962             U8 *s = (U8*)SvPVX(sv);
2963             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2964             if (s < end) {
2965                 rev = utf8_to_uv_chk(s, &len, 0);
2966                 s += len;
2967                 if (s < end) {
2968                     ver = utf8_to_uv_chk(s, &len, 0);
2969                     s += len;
2970                     if (s < end)
2971                         sver = utf8_to_uv_chk(s, &len, 0);
2972                 }
2973             }
2974             if (PERL_REVISION < rev
2975                 || (PERL_REVISION == rev
2976                     && (PERL_VERSION < ver
2977                         || (PERL_VERSION == ver
2978                             && PERL_SUBVERSION < sver))))
2979             {
2980                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2981                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2982                     PERL_VERSION, PERL_SUBVERSION);
2983             }
2984             RETPUSHYES;
2985         }
2986         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2987             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2988                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2989                 + 0.00000099 < SvNV(sv))
2990             {
2991                 NV nrev = SvNV(sv);
2992                 UV rev = (UV)nrev;
2993                 NV nver = (nrev - rev) * 1000;
2994                 UV ver = (UV)(nver + 0.0009);
2995                 NV nsver = (nver - ver) * 1000;
2996                 UV sver = (UV)(nsver + 0.0009);
2997
2998                 /* help out with the "use 5.6" confusion */
2999                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3000                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3001                         "this is only v%d.%d.%d, stopped"
3002                         " (did you mean v%"UVuf".%"UVuf".0?)",
3003                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3004                         PERL_SUBVERSION, rev, ver/100);
3005                 }
3006                 else {
3007                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3008                         "this is only v%d.%d.%d, stopped",
3009                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3010                         PERL_SUBVERSION);
3011                 }
3012             }
3013             RETPUSHYES;
3014         }
3015     }
3016     name = SvPV(sv, len);
3017     if (!(name && len > 0 && *name))
3018         DIE(aTHX_ "Null filename used");
3019     TAINT_PROPER("require");
3020     if (PL_op->op_type == OP_REQUIRE &&
3021       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3022       *svp != &PL_sv_undef)
3023         RETPUSHYES;
3024
3025     /* prepare to compile file */
3026
3027     if (PERL_FILE_IS_ABSOLUTE(name)
3028         || (*name == '.' && (name[1] == '/' ||
3029                              (name[1] == '.' && name[2] == '/'))))
3030     {
3031         tryname = name;
3032         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3033 #ifdef MACOS_TRADITIONAL
3034         /* We consider paths of the form :a:b ambiguous and interpret them first
3035            as global then as local
3036         */
3037         if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
3038             goto trylocal;
3039     }
3040     else
3041 trylocal: {
3042 #else
3043     }
3044     else {
3045 #endif
3046         AV *ar = GvAVn(PL_incgv);
3047         I32 i;
3048 #ifdef VMS
3049         char *unixname;
3050         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3051 #endif
3052         {
3053             namesv = NEWSV(806, 0);
3054             for (i = 0; i <= AvFILL(ar); i++) {
3055                 SV *dirsv = *av_fetch(ar, i, TRUE);
3056
3057                 if (SvROK(dirsv)) {
3058                     int count;
3059                     SV *loader = dirsv;
3060
3061                     if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3062                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3063                     }
3064
3065                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3066                                    PTR2UV(SvANY(loader)), name);
3067                     tryname = SvPVX(namesv);
3068                     tryrsfp = 0;
3069
3070                     ENTER;
3071                     SAVETMPS;
3072                     EXTEND(SP, 2);
3073
3074                     PUSHMARK(SP);
3075                     PUSHs(dirsv);
3076                     PUSHs(sv);
3077                     PUTBACK;
3078                     count = call_sv(loader, G_ARRAY);
3079                     SPAGAIN;
3080
3081                     if (count > 0) {
3082                         int i = 0;
3083                         SV *arg;
3084
3085                         SP -= count - 1;
3086                         arg = SP[i++];
3087
3088                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3089                             arg = SvRV(arg);
3090                         }
3091
3092                         if (SvTYPE(arg) == SVt_PVGV) {
3093                             IO *io = GvIO((GV *)arg);
3094
3095                             ++filter_has_file;
3096
3097                             if (io) {
3098                                 tryrsfp = IoIFP(io);
3099                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3100                                     /* reading from a child process doesn't
3101                                        nest -- when returning from reading
3102                                        the inner module, the outer one is
3103                                        unreadable (closed?)  I've tried to
3104                                        save the gv to manage the lifespan of
3105                                        the pipe, but this didn't help. XXX */
3106                                     filter_child_proc = (GV *)arg;
3107                                     (void)SvREFCNT_inc(filter_child_proc);
3108                                 }
3109                                 else {
3110                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3111                                         PerlIO_close(IoOFP(io));
3112                                     }
3113                                     IoIFP(io) = Nullfp;
3114                                     IoOFP(io) = Nullfp;
3115                                 }
3116                             }
3117
3118                             if (i < count) {
3119                                 arg = SP[i++];
3120                             }
3121                         }
3122
3123                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3124                             filter_sub = arg;
3125                             (void)SvREFCNT_inc(filter_sub);
3126
3127                             if (i < count) {
3128                                 filter_state = SP[i];
3129                                 (void)SvREFCNT_inc(filter_state);
3130                             }
3131
3132                             if (tryrsfp == 0) {
3133                                 tryrsfp = PerlIO_open("/dev/null",
3134                                                       PERL_SCRIPT_MODE);
3135                             }
3136                         }
3137                     }
3138
3139                     PUTBACK;
3140                     FREETMPS;
3141                     LEAVE;
3142
3143                     if (tryrsfp) {
3144                         break;
3145                     }
3146
3147                     filter_has_file = 0;
3148                     if (filter_child_proc) {
3149                         SvREFCNT_dec(filter_child_proc);
3150                         filter_child_proc = 0;
3151                     }
3152                     if (filter_state) {
3153                         SvREFCNT_dec(filter_state);
3154                         filter_state = 0;
3155                     }
3156                     if (filter_sub) {
3157                         SvREFCNT_dec(filter_sub);
3158                         filter_sub = 0;
3159                     }
3160                 }
3161                 else {
3162                     char *dir = SvPVx(dirsv, n_a);
3163 #ifdef MACOS_TRADITIONAL
3164                     char buf[256];
3165                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3166 #else
3167 #ifdef VMS
3168                     char *unixdir;
3169                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3170                         continue;
3171                     sv_setpv(namesv, unixdir);
3172                     sv_catpv(namesv, unixname);
3173 #else
3174                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3175 #endif
3176 #endif
3177                     TAINT_PROPER("require");
3178                     tryname = SvPVX(namesv);
3179 #ifdef MACOS_TRADITIONAL
3180                     {
3181                         /* Convert slashes in the name part, but not the directory part, to colons */
3182                         char * colon;
3183                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3184                             *colon++ = ':';
3185                     }
3186 #endif
3187                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3188                     if (tryrsfp) {
3189                         if (tryname[0] == '.' && tryname[1] == '/')
3190                             tryname += 2;
3191                         break;
3192                     }
3193                 }
3194             }
3195         }
3196     }
3197     SAVECOPFILE_FREE(&PL_compiling);
3198     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3199     SvREFCNT_dec(namesv);
3200     if (!tryrsfp) {
3201         if (PL_op->op_type == OP_REQUIRE) {
3202             char *msgstr = name;
3203             if (namesv) {                       /* did we lookup @INC? */
3204                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3205                 SV *dirmsgsv = NEWSV(0, 0);
3206                 AV *ar = GvAVn(PL_incgv);
3207                 I32 i;
3208                 sv_catpvn(msg, " in @INC", 8);
3209                 if (instr(SvPVX(msg), ".h "))
3210                     sv_catpv(msg, " (change .h to .ph maybe?)");
3211                 if (instr(SvPVX(msg), ".ph "))
3212                     sv_catpv(msg, " (did you run h2ph?)");
3213                 sv_catpv(msg, " (@INC contains:");
3214                 for (i = 0; i <= AvFILL(ar); i++) {
3215                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3216                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3217                     sv_catsv(msg, dirmsgsv);
3218                 }
3219                 sv_catpvn(msg, ")", 1);
3220                 SvREFCNT_dec(dirmsgsv);
3221                 msgstr = SvPV_nolen(msg);
3222             }
3223             DIE(aTHX_ "Can't locate %s", msgstr);
3224         }
3225
3226         RETPUSHUNDEF;
3227     }
3228     else
3229         SETERRNO(0, SS$_NORMAL);
3230
3231     /* Assume success here to prevent recursive requirement. */
3232     (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3233                    newSVpv(CopFILE(&PL_compiling), 0), 0 );
3234
3235     ENTER;
3236     SAVETMPS;
3237     lex_start(sv_2mortal(newSVpvn("",0)));
3238     SAVEGENERICSV(PL_rsfp_filters);
3239     PL_rsfp_filters = Nullav;
3240
3241     PL_rsfp = tryrsfp;
3242     SAVEHINTS();
3243     PL_hints = 0;
3244     SAVESPTR(PL_compiling.cop_warnings);
3245     if (PL_dowarn & G_WARN_ALL_ON)
3246         PL_compiling.cop_warnings = pWARN_ALL ;
3247     else if (PL_dowarn & G_WARN_ALL_OFF)
3248         PL_compiling.cop_warnings = pWARN_NONE ;
3249     else
3250         PL_compiling.cop_warnings = pWARN_STD ;
3251
3252     if (filter_sub || filter_child_proc) {
3253         SV *datasv = filter_add(run_user_filter, Nullsv);
3254         IoLINES(datasv) = filter_has_file;
3255         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3256         IoTOP_GV(datasv) = (GV *)filter_state;
3257         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3258     }
3259
3260     /* switch to eval mode */
3261     push_return(PL_op->op_next);
3262     PUSHBLOCK(cx, CXt_EVAL, SP);
3263     PUSHEVAL(cx, name, Nullgv);
3264
3265     SAVECOPLINE(&PL_compiling);
3266     CopLINE_set(&PL_compiling, 0);
3267
3268     PUTBACK;
3269 #ifdef USE_THREADS
3270     MUTEX_LOCK(&PL_eval_mutex);
3271     if (PL_eval_owner && PL_eval_owner != thr)
3272         while (PL_eval_owner)
3273             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3274     PL_eval_owner = thr;
3275     MUTEX_UNLOCK(&PL_eval_mutex);
3276 #endif /* USE_THREADS */
3277     return DOCATCH(doeval(G_SCALAR, NULL));
3278 }
3279
3280 PP(pp_dofile)
3281 {
3282     return pp_require();
3283 }
3284
3285 PP(pp_entereval)
3286 {
3287     djSP;
3288     register PERL_CONTEXT *cx;
3289     dPOPss;
3290     I32 gimme = GIMME_V, was = PL_sub_generation;
3291     char tbuf[TYPE_DIGITS(long) + 12];
3292     char *tmpbuf = tbuf;
3293     char *safestr;
3294     STRLEN len;
3295     OP *ret;
3296
3297     if (!SvPV(sv,len) || !len)
3298         RETPUSHUNDEF;
3299     TAINT_PROPER("eval");
3300
3301     ENTER;
3302     lex_start(sv);
3303     SAVETMPS;
3304
3305     /* switch to eval mode */
3306
3307     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3308         SV *sv = sv_newmortal();
3309         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3310                        (unsigned long)++PL_evalseq,
3311                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3312         tmpbuf = SvPVX(sv);
3313     }
3314     else
3315         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3316     SAVECOPFILE_FREE(&PL_compiling);
3317     CopFILE_set(&PL_compiling, tmpbuf+2);
3318     SAVECOPLINE(&PL_compiling);
3319     CopLINE_set(&PL_compiling, 1);
3320     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3321        deleting the eval's FILEGV from the stash before gv_check() runs
3322        (i.e. before run-time proper). To work around the coredump that
3323        ensues, we always turn GvMULTI_on for any globals that were
3324        introduced within evals. See force_ident(). GSAR 96-10-12 */
3325     safestr = savepv(tmpbuf);
3326     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3327     SAVEHINTS();
3328     PL_hints = PL_op->op_targ;
3329     SAVESPTR(PL_compiling.cop_warnings);
3330     if (specialWARN(PL_curcop->cop_warnings))
3331         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3332     else {
3333         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3334         SAVEFREESV(PL_compiling.cop_warnings);
3335     }
3336
3337     push_return(PL_op->op_next);
3338     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3339     PUSHEVAL(cx, 0, Nullgv);
3340
3341     /* prepare to compile string */
3342
3343     if (PERLDB_LINE && PL_curstash != PL_debstash)
3344         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3345     PUTBACK;
3346 #ifdef USE_THREADS
3347     MUTEX_LOCK(&PL_eval_mutex);
3348     if (PL_eval_owner && PL_eval_owner != thr)
3349         while (PL_eval_owner)
3350             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3351     PL_eval_owner = thr;
3352     MUTEX_UNLOCK(&PL_eval_mutex);
3353 #endif /* USE_THREADS */
3354     ret = doeval(gimme, NULL);
3355     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3356         && ret != PL_op->op_next) {     /* Successive compilation. */
3357         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3358     }
3359     return DOCATCH(ret);
3360 }
3361
3362 PP(pp_leaveeval)
3363 {
3364     djSP;
3365     register SV **mark;
3366     SV **newsp;
3367     PMOP *newpm;
3368     I32 gimme;
3369     register PERL_CONTEXT *cx;
3370     OP *retop;
3371     U8 save_flags = PL_op -> op_flags;
3372     I32 optype;
3373
3374     POPBLOCK(cx,newpm);
3375     POPEVAL(cx);
3376     retop = pop_return();
3377
3378     TAINT_NOT;
3379     if (gimme == G_VOID)
3380         MARK = newsp;
3381     else if (gimme == G_SCALAR) {
3382         MARK = newsp + 1;
3383         if (MARK <= SP) {
3384             if (SvFLAGS(TOPs) & SVs_TEMP)
3385                 *MARK = TOPs;
3386             else
3387                 *MARK = sv_mortalcopy(TOPs);
3388         }
3389         else {
3390             MEXTEND(mark,0);
3391             *MARK = &PL_sv_undef;
3392         }
3393         SP = MARK;
3394     }
3395     else {
3396         /* in case LEAVE wipes old return values */
3397         for (mark = newsp + 1; mark <= SP; mark++) {
3398             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3399                 *mark = sv_mortalcopy(*mark);
3400                 TAINT_NOT;      /* Each item is independent */
3401             }
3402         }
3403     }
3404     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3405
3406     if (AvFILLp(PL_comppad_name) >= 0)
3407         free_closures();
3408
3409 #ifdef DEBUGGING
3410     assert(CvDEPTH(PL_compcv) == 1);
3411 #endif
3412     CvDEPTH(PL_compcv) = 0;
3413     lex_end();
3414
3415     if (optype == OP_REQUIRE &&
3416         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3417     {
3418         /* Unassume the success we assumed earlier. */
3419         SV *nsv = cx->blk_eval.old_namesv;
3420         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3421         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3422         /* die_where() did LEAVE, or we won't be here */
3423     }
3424     else {
3425         LEAVE;
3426         if (!(save_flags & OPf_SPECIAL))
3427             sv_setpv(ERRSV,"");
3428     }
3429
3430     RETURNOP(retop);
3431 }
3432
3433 PP(pp_entertry)
3434 {
3435     djSP;
3436     register PERL_CONTEXT *cx;
3437     I32 gimme = GIMME_V;
3438
3439     ENTER;
3440     SAVETMPS;
3441
3442     push_return(cLOGOP->op_other->op_next);
3443     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3444     PUSHEVAL(cx, 0, 0);
3445     PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3446
3447     PL_in_eval = EVAL_INEVAL;
3448     sv_setpv(ERRSV,"");
3449     PUTBACK;
3450     return DOCATCH(PL_op->op_next);
3451 }
3452
3453 PP(pp_leavetry)
3454 {
3455     djSP;
3456     register SV **mark;
3457     SV **newsp;
3458     PMOP *newpm;
3459     I32 gimme;
3460     register PERL_CONTEXT *cx;
3461     I32 optype;
3462
3463     POPBLOCK(cx,newpm);
3464     POPEVAL(cx);
3465     pop_return();
3466
3467     TAINT_NOT;
3468     if (gimme == G_VOID)
3469         SP = newsp;
3470     else if (gimme == G_SCALAR) {
3471         MARK = newsp + 1;
3472         if (MARK <= SP) {
3473             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3474                 *MARK = TOPs;
3475             else
3476                 *MARK = sv_mortalcopy(TOPs);
3477         }
3478         else {
3479             MEXTEND(mark,0);
3480             *MARK = &PL_sv_undef;
3481         }
3482         SP = MARK;
3483     }
3484     else {
3485         /* in case LEAVE wipes old return values */
3486         for (mark = newsp + 1; mark <= SP; mark++) {
3487             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3488                 *mark = sv_mortalcopy(*mark);
3489                 TAINT_NOT;      /* Each item is independent */
3490             }
3491         }
3492     }
3493     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3494
3495     LEAVE;
3496     sv_setpv(ERRSV,"");
3497     RETURN;
3498 }
3499
3500 STATIC void
3501 S_doparseform(pTHX_ SV *sv)
3502 {
3503     STRLEN len;
3504     register char *s = SvPV_force(sv, len);
3505     register char *send = s + len;
3506     register char *base;
3507     register I32 skipspaces = 0;
3508     bool noblank;
3509     bool repeat;
3510     bool postspace = FALSE;
3511     U16 *fops;
3512     register U16 *fpc;
3513     U16 *linepc;
3514     register I32 arg;
3515     bool ischop;
3516
3517     if (len == 0)
3518         Perl_croak(aTHX_ "Null picture in formline");
3519
3520     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3521     fpc = fops;
3522
3523     if (s < send) {
3524         linepc = fpc;
3525         *fpc++ = FF_LINEMARK;
3526         noblank = repeat = FALSE;
3527         base = s;
3528     }
3529
3530     while (s <= send) {
3531         switch (*s++) {
3532         default:
3533             skipspaces = 0;
3534             continue;
3535
3536         case '~':
3537             if (*s == '~') {
3538                 repeat = TRUE;
3539                 *s = ' ';
3540             }
3541             noblank = TRUE;
3542             s[-1] = ' ';
3543             /* FALL THROUGH */
3544         case ' ': case '\t':
3545             skipspaces++;
3546             continue;
3547
3548         case '\n': case 0:
3549             arg = s - base;
3550             skipspaces++;
3551             arg -= skipspaces;
3552             if (arg) {
3553                 if (postspace)
3554                     *fpc++ = FF_SPACE;
3555                 *fpc++ = FF_LITERAL;
3556                 *fpc++ = arg;
3557             }
3558             postspace = FALSE;
3559             if (s <= send)
3560                 skipspaces--;
3561             if (skipspaces) {
3562                 *fpc++ = FF_SKIP;
3563                 *fpc++ = skipspaces;
3564             }
3565             skipspaces = 0;
3566             if (s <= send)
3567                 *fpc++ = FF_NEWLINE;
3568             if (noblank) {
3569                 *fpc++ = FF_BLANK;
3570                 if (repeat)
3571                     arg = fpc - linepc + 1;
3572                 else
3573                     arg = 0;
3574                 *fpc++ = arg;
3575             }
3576             if (s < send) {
3577                 linepc = fpc;
3578                 *fpc++ = FF_LINEMARK;
3579                 noblank = repeat = FALSE;
3580                 base = s;
3581             }
3582             else
3583                 s++;
3584             continue;
3585
3586         case '@':
3587         case '^':
3588             ischop = s[-1] == '^';
3589
3590             if (postspace) {
3591                 *fpc++ = FF_SPACE;
3592                 postspace = FALSE;
3593             }
3594             arg = (s - base) - 1;
3595             if (arg) {
3596                 *fpc++ = FF_LITERAL;
3597                 *fpc++ = arg;
3598             }
3599
3600             base = s - 1;
3601             *fpc++ = FF_FETCH;
3602             if (*s == '*') {
3603                 s++;
3604                 *fpc++ = 0;
3605                 *fpc++ = FF_LINEGLOB;
3606             }
3607             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3608                 arg = ischop ? 512 : 0;
3609                 base = s - 1;
3610                 while (*s == '#')
3611                     s++;
3612                 if (*s == '.') {
3613                     char *f;
3614                     s++;
3615                     f = s;
3616                     while (*s == '#')
3617                         s++;
3618                     arg |= 256 + (s - f);
3619                 }
3620                 *fpc++ = s - base;              /* fieldsize for FETCH */
3621                 *fpc++ = FF_DECIMAL;
3622                 *fpc++ = arg;
3623             }
3624             else {
3625                 I32 prespace = 0;
3626                 bool ismore = FALSE;
3627
3628                 if (*s == '>') {
3629                     while (*++s == '>') ;
3630                     prespace = FF_SPACE;
3631                 }
3632                 else if (*s == '|') {
3633                     while (*++s == '|') ;
3634                     prespace = FF_HALFSPACE;
3635                     postspace = TRUE;
3636                 }
3637                 else {
3638                     if (*s == '<')
3639                         while (*++s == '<') ;
3640                     postspace = TRUE;
3641                 }
3642                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3643                     s += 3;
3644                     ismore = TRUE;
3645                 }
3646                 *fpc++ = s - base;              /* fieldsize for FETCH */
3647
3648                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3649
3650                 if (prespace)
3651                     *fpc++ = prespace;
3652                 *fpc++ = FF_ITEM;
3653                 if (ismore)
3654                     *fpc++ = FF_MORE;
3655                 if (ischop)
3656                     *fpc++ = FF_CHOP;
3657             }
3658             base = s;
3659             skipspaces = 0;
3660             continue;
3661         }
3662     }
3663     *fpc++ = FF_END;
3664
3665     arg = fpc - fops;
3666     { /* need to jump to the next word */
3667         int z;
3668         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3669         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3670         s = SvPVX(sv) + SvCUR(sv) + z;
3671     }
3672     Copy(fops, s, arg, U16);
3673     Safefree(fops);
3674     sv_magic(sv, Nullsv, 'f', Nullch, 0);
3675     SvCOMPILED_on(sv);
3676 }
3677
3678 /*
3679  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
3680  *
3681  * The original code was written in conjunction with BSD Computer Software
3682  * Research Group at University of California, Berkeley.
3683  *
3684  * See also: "Optimistic Merge Sort" (SODA '92)
3685  *
3686  * The integration to Perl is by John P. Linderman <jpl@research.att.com>.
3687  *
3688  * The code can be distributed under the same terms as Perl itself.
3689  *
3690  */
3691
3692 #ifdef  TESTHARNESS
3693 #include <sys/types.h>
3694 typedef void SV;
3695 #define pTHXo_
3696 #define pTHX_
3697 #define STATIC
3698 #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE))
3699 #define Safefree(VAR) free(VAR)
3700 typedef int  (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
3701 #endif  /* TESTHARNESS */
3702
3703 typedef char * aptr;            /* pointer for arithmetic on sizes */
3704 typedef SV * gptr;              /* pointers in our lists */
3705
3706 /* Binary merge internal sort, with a few special mods
3707 ** for the special perl environment it now finds itself in.
3708 **
3709 ** Things that were once options have been hotwired
3710 ** to values suitable for this use.  In particular, we'll always
3711 ** initialize looking for natural runs, we'll always produce stable
3712 ** output, and we'll always do Peter McIlroy's binary merge.
3713 */
3714
3715 /* Pointer types for arithmetic and storage and convenience casts */
3716
3717 #define APTR(P) ((aptr)(P))
3718 #define GPTP(P) ((gptr *)(P))
3719 #define GPPP(P) ((gptr **)(P))
3720
3721
3722 /* byte offset from pointer P to (larger) pointer Q */
3723 #define BYTEOFF(P, Q) (APTR(Q) - APTR(P))
3724
3725 #define PSIZE sizeof(gptr)
3726
3727 /* If PSIZE is power of 2, make PSHIFT that power, if that helps */
3728
3729 #ifdef  PSHIFT
3730 #define PNELEM(P, Q)    (BYTEOFF(P,Q) >> (PSHIFT))
3731 #define PNBYTE(N)       ((N) << (PSHIFT))
3732 #define PINDEX(P, N)    (GPTP(APTR(P) + PNBYTE(N)))
3733 #else
3734 /* Leave optimization to compiler */
3735 #define PNELEM(P, Q)    (GPTP(Q) - GPTP(P))
3736 #define PNBYTE(N)       ((N) * (PSIZE))
3737 #define PINDEX(P, N)    (GPTP(P) + (N))
3738 #endif
3739
3740 /* Pointer into other corresponding to pointer into this */
3741 #define POTHER(P, THIS, OTHER) GPTP(APTR(OTHER) + BYTEOFF(THIS,P))
3742
3743 #define FROMTOUPTO(src, dst, lim) do *dst++ = *src++; while(src<lim)
3744
3745
3746 /* Runs are identified by a pointer in the auxilliary list.
3747 ** The pointer is at the start of the list,
3748 ** and it points to the start of the next list.
3749 ** NEXT is used as an lvalue, too.
3750 */
3751
3752 #define NEXT(P)         (*GPPP(P))
3753
3754
3755 /* PTHRESH is the minimum number of pairs with the same sense to justify
3756 ** checking for a run and extending it.  Note that PTHRESH counts PAIRS,
3757 ** not just elements, so PTHRESH == 8 means a run of 16.
3758 */
3759
3760 #define PTHRESH (8)
3761
3762 /* RTHRESH is the number of elements in a run that must compare low
3763 ** to the low element from the opposing run before we justify
3764 ** doing a binary rampup instead of single stepping.
3765 ** In random input, N in a row low should only happen with
3766 ** probability 2^(1-N), so we can risk that we are dealing
3767 ** with orderly input without paying much when we aren't.
3768 */
3769
3770 #define RTHRESH (6)
3771
3772
3773 /*
3774 ** Overview of algorithm and variables.
3775 ** The array of elements at list1 will be organized into runs of length 2,
3776 ** or runs of length >= 2 * PTHRESH.  We only try to form long runs when
3777 ** PTHRESH adjacent pairs compare in the same way, suggesting overall order.
3778 **
3779 ** Unless otherwise specified, pair pointers address the first of two elements.
3780 **
3781 ** b and b+1 are a pair that compare with sense ``sense''.
3782 ** b is the ``bottom'' of adjacent pairs that might form a longer run.
3783 **
3784 ** p2 parallels b in the list2 array, where runs are defined by
3785 ** a pointer chain.
3786 **
3787 ** t represents the ``top'' of the adjacent pairs that might extend
3788 ** the run beginning at b.  Usually, t addresses a pair
3789 ** that compares with opposite sense from (b,b+1).
3790 ** However, it may also address a singleton element at the end of list1,
3791 ** or it may be equal to ``last'', the first element beyond list1.
3792 **
3793 ** r addresses the Nth pair following b.  If this would be beyond t,
3794 ** we back it off to t.  Only when r is less than t do we consider the
3795 ** run long enough to consider checking.
3796 **
3797 ** q addresses a pair such that the pairs at b through q already form a run.
3798 ** Often, q will equal b, indicating we only are sure of the pair itself.
3799 ** However, a search on the previous cycle may have revealed a longer run,
3800 ** so q may be greater than b.
3801 **
3802 ** p is used to work back from a candidate r, trying to reach q,
3803 ** which would mean b through r would be a run.  If we discover such a run,
3804 ** we start q at r and try to push it further towards t.
3805 ** If b through r is NOT a run, we detect the wrong order at (p-1,p).
3806 ** In any event, after the check (if any), we have two main cases.
3807 **
3808 ** 1) Short run.  b <= q < p <= r <= t.
3809 **      b through q is a run (perhaps trivial)
3810 **      q through p are uninteresting pairs
3811 **      p through r is a run
3812 **
3813 ** 2) Long run.  b < r <= q < t.
3814 **      b through q is a run (of length >= 2 * PTHRESH)
3815 **
3816 ** Note that degenerate cases are not only possible, but likely.
3817 ** For example, if the pair following b compares with opposite sense,
3818 ** then b == q < p == r == t.
3819 */
3820
3821
3822 static void
3823 dynprep(pTHX_ gptr *list1, gptr *list2, size_t nmemb, SVCOMPARE_t cmp)
3824 {
3825     int sense;
3826     register gptr *b, *p, *q, *t, *p2;
3827     register gptr c, *last, *r;
3828     gptr *savep;
3829
3830     b = list1;
3831     last = PINDEX(b, nmemb);
3832     sense = (cmp(aTHX_ *b, *(b+1)) > 0);
3833     for (p2 = list2; b < last; ) {
3834         /* We just started, or just reversed sense.
3835         ** Set t at end of pairs with the prevailing sense.
3836         */
3837         for (p = b+2, t = p; ++p < last; t = ++p) {
3838             if ((cmp(aTHX_ *t, *p) > 0) != sense) break;
3839         }
3840         q = b;
3841         /* Having laid out the playing field, look for long runs */
3842         do {
3843             p = r = b + (2 * PTHRESH);
3844             if (r >= t) p = r = t;      /* too short to care about */
3845             else {
3846                 while (((cmp(aTHX_ *(p-1), *p) > 0) == sense) &&
3847                        ((p -= 2) > q));
3848                 if (p <= q) {
3849                     /* b through r is a (long) run.
3850                     ** Extend it as far as possible.
3851                     */
3852                     p = q = r;
3853                     while (((p += 2) < t) &&
3854                            ((cmp(aTHX_ *(p-1), *p) > 0) == sense)) q = p;
3855                     r = p = q + 2;      /* no simple pairs, no after-run */
3856                 }
3857             }
3858             if (q > b) {                /* run of greater than 2 at b */
3859                 savep = p;
3860                 p = q += 2;
3861                 /* pick up singleton, if possible */
3862                 if ((p == t) &&
3863                     ((t + 1) == last) &&
3864                     ((cmp(aTHX_ *(p-1), *p) > 0) == sense))
3865                     savep = r = p = q = last;
3866                 p2 = NEXT(p2) = p2 + (p - b);
3867                 if (sense) while (b < --p) {
3868                     c = *b;
3869                     *b++ = *p;
3870                     *p = c;
3871                 }
3872                 p = savep;
3873             }
3874             while (q < p) {             /* simple pairs */
3875                 p2 = NEXT(p2) = p2 + 2;
3876                 if (sense) {
3877                     c = *q++;
3878                     *(q-1) = *q;
3879                     *q++ = c;
3880                 } else q += 2;
3881             }
3882             if (((b = p) == t) && ((t+1) == last)) {
3883                 NEXT(p2) = p2 + 1;
3884                 b++;
3885             }
3886             q = r;
3887         } while (b < t);
3888         sense = !sense;
3889     }
3890     return;
3891 }
3892
3893
3894 /* Overview of bmerge variables:
3895 **
3896 ** list1 and list2 address the main and auxiliary arrays.
3897 ** They swap identities after each merge pass.
3898 ** Base points to the original list1, so we can tell if
3899 ** the pointers ended up where they belonged (or must be copied).
3900 **
3901 ** When we are merging two lists, f1 and f2 are the next elements
3902 ** on the respective lists.  l1 and l2 mark the end of the lists.
3903 ** tp2 is the current location in the merged list.
3904 **
3905 ** p1 records where f1 started.
3906 ** After the merge, a new descriptor is built there.
3907 **
3908 ** p2 is a ``parallel'' pointer in (what starts as) descriptor space.
3909 ** It is used to identify and delimit the runs.
3910 **
3911 ** In the heat of determining where q, the greater of the f1/f2 elements,
3912 ** belongs in the other list, b, t and p, represent bottom, top and probe
3913 ** locations, respectively, in the other list.
3914 ** They make convenient temporary pointers in other places.
3915 */
3916
3917 STATIC void
3918 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
3919 {
3920     int i, run;
3921     int sense;
3922     register gptr *f1, *f2, *t, *b, *p, *tp2, *l1, *l2, *q;
3923     gptr *aux, *list2, *p2, *last;
3924     gptr *base = list1;
3925     gptr *p1;
3926
3927     if (nmemb <= 1) return;     /* sorted trivially */
3928     New(799,list2,nmemb,gptr);  /* allocate auxilliary array */
3929     aux = list2;
3930     dynprep(aTHX_ list1, list2, nmemb, cmp);
3931     last = PINDEX(list2, nmemb);
3932     while (NEXT(list2) != last) {
3933         /* More than one run remains.  Do some merging to reduce runs. */
3934         l2 = p1 = list1;
3935         for (tp2 = p2 = list2; p2 != last;) {
3936             /* The new first run begins where the old second list ended.
3937             ** Use the p2 ``parallel'' pointer to identify the end of the run.
3938             */
3939             f1 = l2;
3940             t = NEXT(p2);
3941             f2 = l1 = POTHER(t, list2, list1);
3942             if (t != last) t = NEXT(t);
3943             l2 = POTHER(t, list2, list1);
3944             p2 = t;
3945             while (f1 < l1 && f2 < l2) {
3946                 /* If head 1 is larger than head 2, find ALL the elements
3947                 ** in list 2 strictly less than head1, write them all,
3948                 ** then head 1.  Then compare the new heads, and repeat,
3949                 ** until one or both lists are exhausted.
3950                 **
3951                 ** In all comparisons (after establishing
3952                 ** which head to merge) the item to merge
3953                 ** (at pointer q) is the first operand of
3954                 ** the comparison.  When we want to know
3955                 ** if ``q is strictly less than the other'',
3956                 ** we can't just do
3957                 **    cmp(q, other) < 0
3958                 ** because stability demands that we treat equality
3959                 ** as high when q comes from l2, and as low when
3960                 ** q was from l1.  So we ask the question by doing
3961                 **    cmp(q, other) <= sense
3962                 ** and make sense == 0 when equality should look low,
3963                 ** and -1 when equality should look high.
3964                 */
3965
3966
3967                 if (cmp(aTHX_ *f1, *f2) <= 0) {
3968                     q = f2; b = f1; t = l1;
3969                     sense = -1;
3970                 } else {
3971                     q = f1; b = f2; t = l2;
3972                     sense = 0;
3973                 }
3974
3975
3976                 /* ramp up
3977                 **
3978                 ** Leave t at something strictly
3979                 ** greater than q (or at the end of the list),
3980                 ** and b at something strictly less than q.
3981                 */
3982                 for (i = 1, run = 0 ;;) {
3983                     if ((p = PINDEX(b, i)) >= t) {
3984                         /* off the end */
3985                         if (((p = PINDEX(t, -1)) > b) &&
3986                             (cmp(aTHX_ *q, *p) <= sense))
3987                              t = p;
3988                         else b = p;
3989                         break;
3990                     } else if (cmp(aTHX_ *q, *p) <= sense) {
3991                         t = p;
3992                         break;
3993                     } else b = p;
3994                     if (++run >= RTHRESH) i += i;
3995                 }
3996
3997
3998                 /* q is known to follow b and must be inserted before t.
3999                 ** Increment b, so the range of possibilities is [b,t).
4000                 ** Round binary split down, to favor early appearance.
4001                 ** Adjust b and t until q belongs just before t.
4002                 */
4003
4004                 b++;
4005                 while (b < t) {
4006                     p = PINDEX(b, (PNELEM(b, t) - 1) / 2);
4007                     if (cmp(aTHX_ *q, *p) <= sense) {
4008                         t = p;
4009                     } else b = p + 1;
4010                 }
4011
4012
4013                 /* Copy all the strictly low elements */
4014
4015                 if (q == f1) {
4016                     FROMTOUPTO(f2, tp2, t);
4017                     *tp2++ = *f1++;
4018                 } else {
4019                     FROMTOUPTO(f1, tp2, t);
4020                     *tp2++ = *f2++;
4021                 }
4022             }
4023
4024
4025             /* Run out remaining list */
4026             if (f1 == l1) {
4027                    if (f2 < l2) FROMTOUPTO(f2, tp2, l2);
4028             } else              FROMTOUPTO(f1, tp2, l1);
4029             p1 = NEXT(p1) = POTHER(tp2, list2, list1);
4030         }
4031         t = list1;
4032         list1 = list2;
4033         list2 = t;
4034         last = PINDEX(list2, nmemb);
4035     }
4036     if (base == list2) {
4037         last = PINDEX(list1, nmemb);
4038         FROMTOUPTO(list1, list2, last);
4039     }
4040     Safefree(aux);
4041     return;
4042 }
4043
4044
4045 #ifdef PERL_OBJECT
4046 #undef this
4047 #define this pPerl
4048 #include "XSUB.h"
4049 #endif
4050
4051
4052 static I32
4053 sortcv(pTHXo_ SV *a, SV *b)
4054 {
4055     dTHR;
4056     I32 oldsaveix = PL_savestack_ix;
4057     I32 oldscopeix = PL_scopestack_ix;
4058     I32 result;
4059     GvSV(PL_firstgv) = a;
4060     GvSV(PL_secondgv) = b;
4061     PL_stack_sp = PL_stack_base;
4062     PL_op = PL_sortcop;
4063     CALLRUNOPS(aTHX);
4064     if (PL_stack_sp != PL_stack_base + 1)
4065         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4066     if (!SvNIOKp(*PL_stack_sp))
4067         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4068     result = SvIV(*PL_stack_sp);
4069     while (PL_scopestack_ix > oldscopeix) {
4070         LEAVE;
4071     }
4072     leave_scope(oldsaveix);
4073     return result;
4074 }
4075
4076 static I32
4077 sortcv_stacked(pTHXo_ SV *a, SV *b)
4078 {
4079     dTHR;
4080     I32 oldsaveix = PL_savestack_ix;
4081     I32 oldscopeix = PL_scopestack_ix;
4082     I32 result;
4083     AV *av;
4084
4085 #ifdef USE_THREADS
4086     av = (AV*)PL_curpad[0];
4087 #else
4088     av = GvAV(PL_defgv);
4089 #endif
4090
4091     if (AvMAX(av) < 1) {
4092         SV** ary = AvALLOC(av);
4093         if (AvARRAY(av) != ary) {
4094             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4095             SvPVX(av) = (char*)ary;
4096         }
4097         if (AvMAX(av) < 1) {
4098             AvMAX(av) = 1;
4099             Renew(ary,2,SV*);
4100             SvPVX(av) = (char*)ary;
4101         }
4102     }
4103     AvFILLp(av) = 1;
4104
4105     AvARRAY(av)[0] = a;
4106     AvARRAY(av)[1] = b;
4107     PL_stack_sp = PL_stack_base;
4108     PL_op = PL_sortcop;
4109     CALLRUNOPS(aTHX);
4110     if (PL_stack_sp != PL_stack_base + 1)
4111         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4112     if (!SvNIOKp(*PL_stack_sp))
4113         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4114     result = SvIV(*PL_stack_sp);
4115     while (PL_scopestack_ix > oldscopeix) {
4116         LEAVE;
4117     }
4118     leave_scope(oldsaveix);
4119     return result;
4120 }
4121
4122 static I32
4123 sortcv_xsub(pTHXo_ SV *a, SV *b)
4124 {
4125     dSP;
4126     I32 oldsaveix = PL_savestack_ix;
4127     I32 oldscopeix = PL_scopestack_ix;
4128     I32 result;
4129     CV *cv=(CV*)PL_sortcop;
4130
4131     SP = PL_stack_base;
4132     PUSHMARK(SP);
4133     EXTEND(SP, 2);
4134     *++SP = a;
4135     *++SP = b;
4136     PUTBACK;
4137     (void)(*CvXSUB(cv))(aTHXo_ cv);
4138     if (PL_stack_sp != PL_stack_base + 1)
4139         Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4140     if (!SvNIOKp(*PL_stack_sp))
4141         Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4142     result = SvIV(*PL_stack_sp);
4143     while (PL_scopestack_ix > oldscopeix) {
4144         LEAVE;
4145     }
4146     leave_scope(oldsaveix);
4147     return result;
4148 }
4149
4150
4151 static I32
4152 sv_ncmp(pTHXo_ SV *a, SV *b)
4153 {
4154     NV nv1 = SvNV(a);
4155     NV nv2 = SvNV(b);
4156     return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4157 }
4158
4159 static I32
4160 sv_i_ncmp(pTHXo_ SV *a, SV *b)
4161 {
4162     IV iv1 = SvIV(a);
4163     IV iv2 = SvIV(b);
4164     return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4165 }
4166 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4167           *svp = Nullsv;                                \
4168           if (PL_amagic_generation) { \
4169             if (SvAMAGIC(left)||SvAMAGIC(right))\
4170                 *svp = amagic_call(left, \
4171                                    right, \
4172                                    CAT2(meth,_amg), \
4173                                    0); \
4174           } \
4175         } STMT_END
4176
4177 static I32
4178 amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4179 {
4180     SV *tmpsv;
4181     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4182     if (tmpsv) {
4183         NV d;
4184
4185         if (SvIOK(tmpsv)) {
4186             I32 i = SvIVX(tmpsv);
4187             if (i > 0)
4188                return 1;
4189             return i? -1 : 0;
4190         }
4191         d = SvNV(tmpsv);
4192         if (d > 0)
4193            return 1;
4194         return d? -1 : 0;
4195      }
4196      return sv_ncmp(aTHXo_ a, b);
4197 }
4198
4199 static I32
4200 amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4201 {
4202     SV *tmpsv;
4203     tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4204     if (tmpsv) {
4205         NV d;
4206
4207         if (SvIOK(tmpsv)) {
4208             I32 i = SvIVX(tmpsv);
4209             if (i > 0)
4210                return 1;
4211             return i? -1 : 0;
4212         }
4213         d = SvNV(tmpsv);
4214         if (d > 0)
4215            return 1;
4216         return d? -1 : 0;
4217     }
4218     return sv_i_ncmp(aTHXo_ a, b);
4219 }
4220
4221 static I32
4222 amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4223 {
4224     SV *tmpsv;
4225     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4226     if (tmpsv) {
4227         NV d;
4228
4229         if (SvIOK(tmpsv)) {
4230             I32 i = SvIVX(tmpsv);
4231             if (i > 0)
4232                return 1;
4233             return i? -1 : 0;
4234         }
4235         d = SvNV(tmpsv);
4236         if (d > 0)
4237            return 1;
4238         return d? -1 : 0;
4239     }
4240     return sv_cmp(str1, str2);
4241 }
4242
4243 static I32
4244 amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4245 {
4246     SV *tmpsv;
4247     tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4248     if (tmpsv) {
4249         NV d;
4250
4251         if (SvIOK(tmpsv)) {
4252             I32 i = SvIVX(tmpsv);
4253             if (i > 0)
4254                return 1;
4255             return i? -1 : 0;
4256         }
4257         d = SvNV(tmpsv);
4258         if (d > 0)
4259            return 1;
4260         return d? -1 : 0;
4261     }
4262     return sv_cmp_locale(str1, str2);
4263 }
4264
4265 static I32
4266 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4267 {
4268     SV *datasv = FILTER_DATA(idx);
4269     int filter_has_file = IoLINES(datasv);
4270     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4271     SV *filter_state = (SV *)IoTOP_GV(datasv);
4272     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4273     int len = 0;
4274
4275     /* I was having segfault trouble under Linux 2.2.5 after a
4276        parse error occured.  (Had to hack around it with a test
4277        for PL_error_count == 0.)  Solaris doesn't segfault --
4278        not sure where the trouble is yet.  XXX */
4279
4280     if (filter_has_file) {
4281         len = FILTER_READ(idx+1, buf_sv, maxlen);
4282     }
4283
4284     if (filter_sub && len >= 0) {
4285         djSP;
4286         int count;
4287
4288         ENTER;
4289         SAVE_DEFSV;
4290         SAVETMPS;
4291         EXTEND(SP, 2);
4292
4293         DEFSV = buf_sv;
4294         PUSHMARK(SP);
4295         PUSHs(sv_2mortal(newSViv(maxlen)));
4296         if (filter_state) {
4297             PUSHs(filter_state);
4298         }
4299         PUTBACK;
4300         count = call_sv(filter_sub, G_SCALAR);
4301         SPAGAIN;
4302
4303         if (count > 0) {
4304             SV *out = POPs;
4305             if (SvOK(out)) {
4306                 len = SvIV(out);
4307             }
4308         }
4309
4310         PUTBACK;
4311         FREETMPS;
4312         LEAVE;
4313     }
4314
4315     if (len <= 0) {
4316         IoLINES(datasv) = 0;
4317         if (filter_child_proc) {
4318             SvREFCNT_dec(filter_child_proc);
4319             IoFMT_GV(datasv) = Nullgv;
4320         }
4321         if (filter_state) {
4322             SvREFCNT_dec(filter_state);
4323             IoTOP_GV(datasv) = Nullgv;
4324         }
4325         if (filter_sub) {
4326             SvREFCNT_dec(filter_sub);
4327             IoBOTTOM_GV(datasv) = Nullgv;
4328         }
4329         filter_del(run_user_filter);
4330     }
4331
4332     return len;
4333 }
4334
4335 #ifdef PERL_OBJECT
4336
4337 static I32
4338 sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4339 {
4340     return sv_cmp_locale(str1, str2);
4341 }
4342
4343 static I32
4344 sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4345 {
4346     return sv_cmp(str1, str2);
4347 }
4348
4349 #endif /* PERL_OBJECT */