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