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