pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2003, 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 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  30
  31 PP(pp_wantarray)
  32 {
  33     dSP;
  34     I32 cxix;
  35     EXTEND(SP, 1);
  36
  37     cxix = dopoptosub(cxstack_ix);
  38     if (cxix < 0)
  39         RETPUSHUNDEF;
  40
  41     switch (cxstack[cxix].blk_gimme) {
  42     case G_ARRAY:
  43         RETPUSHYES;
  44     case G_SCALAR:
  45         RETPUSHNO;
  46     default:
  47         RETPUSHUNDEF;
  48     }
  49 }
  50
  51 PP(pp_regcmaybe)
  52 {
  53     return NORMAL;
  54 }
  55
  56 PP(pp_regcreset)
  57 {
  58     /* XXXX Should store the old value to allow for tie/overload - and
  59        restore in regcomp, where marked with XXXX. */
  60     PL_reginterp_cnt = 0;
  61     return NORMAL;
  62 }
  63
  64 PP(pp_regcomp)
  65 {
  66     dSP;
  67     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  68     register char *t;
  69     SV *tmpstr;
  70     STRLEN len;
  71     MAGIC *mg = Null(MAGIC*);
  72
  73     tmpstr = POPs;
  74
  75     /* prevent recompiling under /o and ithreads. */
  76 #if defined(USE_ITHREADS)
  77     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
  78          RETURN;
  79 #endif
  80
  81     if (SvROK(tmpstr)) {
  82         SV *sv = SvRV(tmpstr);
  83         if(SvMAGICAL(sv))
  84             mg = mg_find(sv, PERL_MAGIC_qr);
  85     }
  86     if (mg) {
  87         regexp *re = (regexp *)mg->mg_obj;
  88         ReREFCNT_dec(PM_GETRE(pm));
  89         PM_SETRE(pm, ReREFCNT_inc(re));
  90     }
  91     else {
  92         t = SvPV(tmpstr, len);
  93
  94         /* Check against the last compiled regexp. */
  95         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
  96             PM_GETRE(pm)->prelen != (I32)len ||
  97             memNE(PM_GETRE(pm)->precomp, t, len))
  98         {
  99             if (PM_GETRE(pm)) {
 100                 ReREFCNT_dec(PM_GETRE(pm));
 101                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
 102             }
 103             if (PL_op->op_flags & OPf_SPECIAL)
 104                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 105
 106             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 107             if (DO_UTF8(tmpstr))
 108                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 109             else {
 110                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 111                 if (pm->op_pmdynflags & PMdf_UTF8)
 112                     t = (char*)bytes_to_utf8((U8*)t, &len);
 113             }
 114             PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
 115             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
 116                 Safefree(t);
 117             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 118                                            inside tie/overload accessors.  */
 119         }
 120     }
 121
 122 #ifndef INCOMPLETE_TAINTS
 123     if (PL_tainting) {
 124         if (PL_tainted)
 125             pm->op_pmdynflags |= PMdf_TAINTED;
 126         else
 127             pm->op_pmdynflags &= ~PMdf_TAINTED;
 128     }
 129 #endif
 130
 131     if (!PM_GETRE(pm)->prelen && PL_curpm)
 132         pm = PL_curpm;
 133     else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
 134         pm->op_pmflags |= PMf_WHITE;
 135     else
 136         pm->op_pmflags &= ~PMf_WHITE;
 137
 138     /* XXX runtime compiled output needs to move to the pad */
 139     if (pm->op_pmflags & PMf_KEEP) {
 140         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 141 #if !defined(USE_ITHREADS)
 142         /* XXX can't change the optree at runtime either */
 143         cLOGOP->op_first->op_next = PL_op->op_next;
 144 #endif
 145     }
 146     RETURN;
 147 }
 148
 149 PP(pp_substcont)
 150 {
 151     dSP;
 152     register PMOP *pm = (PMOP*) cLOGOP->op_other;
 153     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 154     register SV *dstr = cx->sb_dstr;
 155     register char *s = cx->sb_s;
 156     register char *m = cx->sb_m;
 157     char *orig = cx->sb_orig;
 158     register REGEXP *rx = cx->sb_rx;
 159     SV *nsv = Nullsv;
 160
 161     rxres_restore(&cx->sb_rxres, rx);
 162     RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
 163
 164     if (cx->sb_iters++) {
 165         I32 saviters = cx->sb_iters;
 166         if (cx->sb_iters > cx->sb_maxiters)
 167             DIE(aTHX_ "Substitution loop");
 168
 169         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 170             cx->sb_rxtainted |= 2;
 171         sv_catsv(dstr, POPs);
 172
 173         /* Are we done */
 174         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 175                                      s == m, cx->sb_targ, NULL,
 176                                      ((cx->sb_rflags & REXEC_COPY_STR)
 177                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 178                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 179         {
 180             SV *targ = cx->sb_targ;
 181
 182             if (DO_UTF8(dstr) && !SvUTF8(targ))
 183                 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 184             else
 185                 sv_catpvn(dstr, s, cx->sb_strend - s);
 186             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 187
 188 #ifdef PERL_COPY_ON_WRITE
 189             if (SvIsCOW(targ)) {
 190                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 191             } else
 192 #endif
 193             {
 194                 (void)SvOOK_off(targ);
 195                 if (SvLEN(targ))
 196                     Safefree(SvPVX(targ));
 197             }
 198             SvPVX(targ) = SvPVX(dstr);
 199             SvCUR_set(targ, SvCUR(dstr));
 200             SvLEN_set(targ, SvLEN(dstr));
 201             if (DO_UTF8(dstr))
 202                 SvUTF8_on(targ);
 203             SvPVX(dstr) = 0;
 204             sv_free(dstr);
 205
 206             TAINT_IF(cx->sb_rxtainted & 1);
 207             PUSHs(sv_2mortal(newSViv(saviters - 1)));
 208
 209             (void)SvPOK_only_UTF8(targ);
 210             TAINT_IF(cx->sb_rxtainted);
 211             SvSETMAGIC(targ);
 212             SvTAINT(targ);
 213
 214             LEAVE_SCOPE(cx->sb_oldsave);
 215             POPSUBST(cx);
 216             RETURNOP(pm->op_next);
 217         }
 218         cx->sb_iters = saviters;
 219     }
 220     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 221         m = s;
 222         s = orig;
 223         cx->sb_orig = orig = rx->subbeg;
 224         s = orig + (m - s);
 225         cx->sb_strend = s + (cx->sb_strend - m);
 226     }
 227     cx->sb_m = m = rx->startp[0] + orig;
 228     if (m > s) {
 229         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 230             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 231         else
 232             sv_catpvn(dstr, s, m-s);
 233     }
 234     cx->sb_s = rx->endp[0] + orig;
 235     { /* Update the pos() information. */
 236         SV *sv = cx->sb_targ;
 237         MAGIC *mg;
 238         I32 i;
 239         if (SvTYPE(sv) < SVt_PVMG)
 240             (void)SvUPGRADE(sv, SVt_PVMG);
 241         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 242             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 243             mg = mg_find(sv, PERL_MAGIC_regex_global);
 244         }
 245         i = m - orig;
 246         if (DO_UTF8(sv))
 247             sv_pos_b2u(sv, &i);
 248         mg->mg_len = i;
 249     }
 250     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 251     rxres_save(&cx->sb_rxres, rx);
 252     RETURNOP(pm->op_pmreplstart);
 253 }
 254
 255 void
 256 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 257 {
 258     UV *p = (UV*)*rsp;
 259     U32 i;
 260
 261     if (!p || p[1] < rx->nparens) {
 262 #ifdef PERL_COPY_ON_WRITE
 263         i = 7 + rx->nparens * 2;
 264 #else
 265         i = 6 + rx->nparens * 2;
 266 #endif
 267         if (!p)
 268             New(501, p, i, UV);
 269         else
 270             Renew(p, i, UV);
 271         *rsp = (void*)p;
 272     }
 273
 274     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 275     RX_MATCH_COPIED_off(rx);
 276
 277 #ifdef PERL_COPY_ON_WRITE
 278     *p++ = PTR2UV(rx->saved_copy);
 279     rx->saved_copy = Nullsv;
 280 #endif
 281
 282     *p++ = rx->nparens;
 283
 284     *p++ = PTR2UV(rx->subbeg);
 285     *p++ = (UV)rx->sublen;
 286     for (i = 0; i <= rx->nparens; ++i) {
 287         *p++ = (UV)rx->startp[i];
 288         *p++ = (UV)rx->endp[i];
 289     }
 290 }
 291
 292 void
 293 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 294 {
 295     UV *p = (UV*)*rsp;
 296     U32 i;
 297
 298     RX_MATCH_COPY_FREE(rx);
 299     RX_MATCH_COPIED_set(rx, *p);
 300     *p++ = 0;
 301
 302 #ifdef PERL_COPY_ON_WRITE
 303     if (rx->saved_copy)
 304         SvREFCNT_dec (rx->saved_copy);
 305     rx->saved_copy = INT2PTR(SV*,*p);
 306     *p++ = 0;
 307 #endif
 308
 309     rx->nparens = *p++;
 310
 311     rx->subbeg = INT2PTR(char*,*p++);
 312     rx->sublen = (I32)(*p++);
 313     for (i = 0; i <= rx->nparens; ++i) {
 314         rx->startp[i] = (I32)(*p++);
 315         rx->endp[i] = (I32)(*p++);
 316     }
 317 }
 318
 319 void
 320 Perl_rxres_free(pTHX_ void **rsp)
 321 {
 322     UV *p = (UV*)*rsp;
 323
 324     if (p) {
 325         Safefree(INT2PTR(char*,*p));
 326 #ifdef PERL_COPY_ON_WRITE
 327         if (p[1]) {
 328             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 329         }
 330 #endif
 331         Safefree(p);
 332         *rsp = Null(void*);
 333     }
 334 }
 335
 336 PP(pp_formline)
 337 {
 338     dSP; dMARK; dORIGMARK;
 339     register SV *tmpForm = *++MARK;
 340     register U16 *fpc;
 341     register char *t;
 342     register char *f;
 343     register char *s;
 344     register char *send;
 345     register I32 arg;
 346     register SV *sv = Nullsv;
 347     char *item = Nullch;
 348     I32 itemsize  = 0;
 349     I32 fieldsize = 0;
 350     I32 lines = 0;
 351     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 352     char *chophere = Nullch;
 353     char *linemark = Nullch;
 354     NV value;
 355     bool gotsome = FALSE;
 356     STRLEN len;
 357     STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
 358     bool item_is_utf8 = FALSE;
 359     bool targ_is_utf8 = FALSE;
 360     SV * nsv = Nullsv;
 361
 362     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 363         if (SvREADONLY(tmpForm)) {
 364             SvREADONLY_off(tmpForm);
 365             doparseform(tmpForm);
 366             SvREADONLY_on(tmpForm);
 367         }
 368         else
 369             doparseform(tmpForm);
 370     }
 371     SvPV_force(PL_formtarget, len);
 372     if (DO_UTF8(PL_formtarget))
 373         targ_is_utf8 = TRUE;
 374     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 375     t += len;
 376     f = SvPV(tmpForm, len);
 377     /* need to jump to the next word */
 378     s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
 379
 380     fpc = (U16*)s;
 381
 382     for (;;) {
 383         DEBUG_f( {
 384             char *name = "???";
 385             arg = -1;
 386             switch (*fpc) {
 387             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 388             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 389             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 390             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 391             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 392
 393             case FF_CHECKNL:    name = "CHECKNL";       break;
 394             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 395             case FF_SPACE:      name = "SPACE";         break;
 396             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 397             case FF_ITEM:       name = "ITEM";          break;
 398             case FF_CHOP:       name = "CHOP";          break;
 399             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 400             case FF_NEWLINE:    name = "NEWLINE";       break;
 401             case FF_MORE:       name = "MORE";          break;
 402             case FF_LINEMARK:   name = "LINEMARK";      break;
 403             case FF_END:        name = "END";           break;
 404             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 405             }
 406             if (arg >= 0)
 407                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 408             else
 409                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 410         } );
 411         switch (*fpc++) {
 412         case FF_LINEMARK:
 413             linemark = t;
 414             lines++;
 415             gotsome = FALSE;
 416             break;
 417
 418         case FF_LITERAL:
 419             arg = *fpc++;
 420             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 421                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 422                 *t = '\0';
 423                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 424                 t = SvEND(PL_formtarget);
 425                 break;
 426             }
 427             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 428                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 429                 *t = '\0';
 430                 sv_utf8_upgrade(PL_formtarget);
 431                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 432                 t = SvEND(PL_formtarget);
 433                 targ_is_utf8 = TRUE;
 434             }
 435             while (arg--)
 436                 *t++ = *f++;
 437             break;
 438
 439         case FF_SKIP:
 440             f += *fpc++;
 441             break;
 442
 443         case FF_FETCH:
 444             arg = *fpc++;
 445             f += arg;
 446             fieldsize = arg;
 447
 448             if (MARK < SP)
 449                 sv = *++MARK;
 450             else {
 451                 sv = &PL_sv_no;
 452                 if (ckWARN(WARN_SYNTAX))
 453                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 454             }
 455             break;
 456
 457         case FF_CHECKNL:
 458             item = s = SvPV(sv, len);
 459             itemsize = len;
 460             if (DO_UTF8(sv)) {
 461                 itemsize = sv_len_utf8(sv);
 462                 if (itemsize != (I32)len) {
 463                     I32 itembytes;
 464                     if (itemsize > fieldsize) {
 465                         itemsize = fieldsize;
 466                         itembytes = itemsize;
 467                         sv_pos_u2b(sv, &itembytes, 0);
 468                     }
 469                     else
 470                         itembytes = len;
 471                     send = chophere = s + itembytes;
 472                     while (s < send) {
 473                         if (*s & ~31)
 474                             gotsome = TRUE;
 475                         else if (*s == '\n')
 476                             break;
 477                         s++;
 478                     }
 479                     item_is_utf8 = TRUE;
 480                     itemsize = s - item;
 481                     sv_pos_b2u(sv, &itemsize);
 482                     break;
 483                 }
 484             }
 485             item_is_utf8 = FALSE;
 486             if (itemsize > fieldsize)
 487                 itemsize = fieldsize;
 488             send = chophere = s + itemsize;
 489             while (s < send) {
 490                 if (*s & ~31)
 491                     gotsome = TRUE;
 492                 else if (*s == '\n')
 493                     break;
 494                 s++;
 495             }
 496             itemsize = s - item;
 497             break;
 498
 499         case FF_CHECKCHOP:
 500             item = s = SvPV(sv, len);
 501             itemsize = len;
 502             if (DO_UTF8(sv)) {
 503                 itemsize = sv_len_utf8(sv);
 504                 if (itemsize != (I32)len) {
 505                     I32 itembytes;
 506                     if (itemsize <= fieldsize) {
 507                         send = chophere = s + itemsize;
 508                         while (s < send) {
 509                             if (*s == '\r') {
 510                                 itemsize = s - item;
 511                                 break;
 512                             }
 513                             if (*s++ & ~31)
 514                                 gotsome = TRUE;
 515                         }
 516                     }
 517                     else {
 518                         itemsize = fieldsize;
 519                         itembytes = itemsize;
 520                         sv_pos_u2b(sv, &itembytes, 0);
 521                         send = chophere = s + itembytes;
 522                         while (s < send || (s == send && isSPACE(*s))) {
 523                             if (isSPACE(*s)) {
 524                                 if (chopspace)
 525                                     chophere = s;
 526                                 if (*s == '\r')
 527                                     break;
 528                             }
 529                             else {
 530                                 if (*s & ~31)
 531                                     gotsome = TRUE;
 532                                 if (strchr(PL_chopset, *s))
 533                                     chophere = s + 1;
 534                             }
 535                             s++;
 536                         }
 537                         itemsize = chophere - item;
 538                         sv_pos_b2u(sv, &itemsize);
 539                     }
 540                     item_is_utf8 = TRUE;
 541                     break;
 542                 }
 543             }
 544             item_is_utf8 = FALSE;
 545             if (itemsize <= fieldsize) {
 546                 send = chophere = s + itemsize;
 547                 while (s < send) {
 548                     if (*s == '\r') {
 549                         itemsize = s - item;
 550                         break;
 551                     }
 552                     if (*s++ & ~31)
 553                         gotsome = TRUE;
 554                 }
 555             }
 556             else {
 557                 itemsize = fieldsize;
 558                 send = chophere = s + itemsize;
 559                 while (s < send || (s == send && isSPACE(*s))) {
 560                     if (isSPACE(*s)) {
 561                         if (chopspace)
 562                             chophere = s;
 563                         if (*s == '\r')
 564                             break;
 565                     }
 566                     else {
 567                         if (*s & ~31)
 568                             gotsome = TRUE;
 569                         if (strchr(PL_chopset, *s))
 570                             chophere = s + 1;
 571                     }
 572                     s++;
 573                 }
 574                 itemsize = chophere - item;
 575             }
 576             break;
 577
 578         case FF_SPACE:
 579             arg = fieldsize - itemsize;
 580             if (arg) {
 581                 fieldsize -= arg;
 582                 while (arg-- > 0)
 583                     *t++ = ' ';
 584             }
 585             break;
 586
 587         case FF_HALFSPACE:
 588             arg = fieldsize - itemsize;
 589             if (arg) {
 590                 arg /= 2;
 591                 fieldsize -= arg;
 592                 while (arg-- > 0)
 593                     *t++ = ' ';
 594             }
 595             break;
 596
 597         case FF_ITEM:
 598             arg = itemsize;
 599             s = item;
 600             if (item_is_utf8) {
 601                 if (!targ_is_utf8) {
 602                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 603                     *t = '\0';
 604                     sv_utf8_upgrade(PL_formtarget);
 605                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 606                     t = SvEND(PL_formtarget);
 607                     targ_is_utf8 = TRUE;
 608                 }
 609                 while (arg--) {
 610                     if (UTF8_IS_CONTINUED(*s)) {
 611                         STRLEN skip = UTF8SKIP(s);
 612                         switch (skip) {
 613                         default:
 614                             Move(s,t,skip,char);
 615                             s += skip;
 616                             t += skip;
 617                             break;
 618                         case 7: *t++ = *s++;
 619                         case 6: *t++ = *s++;
 620                         case 5: *t++ = *s++;
 621                         case 4: *t++ = *s++;
 622                         case 3: *t++ = *s++;
 623                         case 2: *t++ = *s++;
 624                         case 1: *t++ = *s++;
 625                         }
 626                     }
 627                     else {
 628                         if ( !((*t++ = *s++) & ~31) )
 629                             t[-1] = ' ';
 630                     }
 631                 }
 632                 break;
 633             }
 634             if (targ_is_utf8 && !item_is_utf8) {
 635                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 636                 *t = '\0';
 637                 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 638                 for (; t < SvEND(PL_formtarget); t++) {
 639 #ifdef EBCDIC
 640                     int ch = *t++ = *s++;
 641                     if (iscntrl(ch))
 642 #else
 643                     if (!(*t & ~31))
 644 #endif
 645                         *t = ' ';
 646                 }
 647                 break;
 648             }
 649             while (arg--) {
 650 #ifdef EBCDIC
 651                 int ch = *t++ = *s++;
 652                 if (iscntrl(ch))
 653 #else
 654                 if ( !((*t++ = *s++) & ~31) )
 655 #endif
 656                     t[-1] = ' ';
 657             }
 658             break;
 659
 660         case FF_CHOP:
 661             s = chophere;
 662             if (chopspace) {
 663                 while (*s && isSPACE(*s))
 664                     s++;
 665             }
 666             sv_chop(sv,s);
 667             break;
 668
 669         case FF_LINEGLOB:
 670             item = s = SvPV(sv, len);
 671             itemsize = len;
 672             if ((item_is_utf8 = DO_UTF8(sv)))
 673                 itemsize = sv_len_utf8(sv);
 674             if (itemsize) {
 675                 bool chopped = FALSE;
 676                 gotsome = TRUE;
 677                 send = s + len;
 678                 while (s < send) {
 679                     if (*s++ == '\n') {
 680                         if (s == send) {
 681                             itemsize--;
 682                             chopped = TRUE;
 683                         }
 684                         else
 685                             lines++;
 686                     }
 687                 }
 688                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 689                 if (targ_is_utf8)
 690                     SvUTF8_on(PL_formtarget);
 691                 sv_catsv(PL_formtarget, sv);
 692                 if (chopped)
 693                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 694                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 695                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 696                 if (item_is_utf8)
 697                     targ_is_utf8 = TRUE;
 698             }
 699             break;
 700
 701         case FF_DECIMAL:
 702             /* If the field is marked with ^ and the value is undefined,
 703                blank it out. */
 704             arg = *fpc++;
 705             if ((arg & 512) && !SvOK(sv)) {
 706                 arg = fieldsize;
 707                 while (arg--)
 708                     *t++ = ' ';
 709                 break;
 710             }
 711             gotsome = TRUE;
 712             value = SvNV(sv);
 713             /* Formats aren't yet marked for locales, so assume "yes". */
 714             {
 715                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 716 #if defined(USE_LONG_DOUBLE)
 717                 if (arg & 256) {
 718                     sprintf(t, "%#*.*" PERL_PRIfldbl,
 719                             (int) fieldsize, (int) arg & 255, value);
 720                 } else {
 721                     sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
 722                 }
 723 #else
 724                 if (arg & 256) {
 725                     sprintf(t, "%#*.*f",
 726                             (int) fieldsize, (int) arg & 255, value);
 727                 } else {
 728                     sprintf(t, "%*.0f",
 729                             (int) fieldsize, value);
 730                 }
 731 #endif
 732                 RESTORE_NUMERIC_STANDARD();
 733             }
 734             t += fieldsize;
 735             break;
 736
 737         case FF_0DECIMAL:
 738             /* If the field is marked with ^ and the value is undefined,
 739                blank it out. */
 740             arg = *fpc++;
 741             if ((arg & 512) && !SvOK(sv)) {
 742                 arg = fieldsize;
 743                 while (arg--)
 744                     *t++ = ' ';
 745                 break;
 746             }
 747             gotsome = TRUE;
 748             value = SvNV(sv);
 749             /* Formats aren't yet marked for locales, so assume "yes". */
 750             {
 751                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 752 #if defined(USE_LONG_DOUBLE)
 753                 if (arg & 256) {
 754                     sprintf(t, "%#0*.*" PERL_PRIfldbl,
 755                             (int) fieldsize, (int) arg & 255, value);
 756 /* is this legal? I don't have long doubles */
 757                 } else {
 758                     sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
 759                 }
 760 #else
 761                 if (arg & 256) {
 762                     sprintf(t, "%#0*.*f",
 763                             (int) fieldsize, (int) arg & 255, value);
 764                 } else {
 765                     sprintf(t, "%0*.0f",
 766                             (int) fieldsize, value);
 767                 }
 768 #endif
 769                 RESTORE_NUMERIC_STANDARD();
 770             }
 771             t += fieldsize;
 772             break;
 773
 774         case FF_NEWLINE:
 775             f++;
 776             while (t-- > linemark && *t == ' ') ;
 777             t++;
 778             *t++ = '\n';
 779             break;
 780
 781         case FF_BLANK:
 782             arg = *fpc++;
 783             if (gotsome) {
 784                 if (arg) {              /* repeat until fields exhausted? */
 785                     *t = '\0';
 786                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 787                     lines += FmLINES(PL_formtarget);
 788                     if (lines == 200) {
 789                         arg = t - linemark;
 790                         if (strnEQ(linemark, linemark - arg, arg))
 791                             DIE(aTHX_ "Runaway format");
 792                     }
 793                     if (targ_is_utf8)
 794                         SvUTF8_on(PL_formtarget);
 795                     FmLINES(PL_formtarget) = lines;
 796                     SP = ORIGMARK;
 797                     RETURNOP(cLISTOP->op_first);
 798                 }
 799             }
 800             else {
 801                 t = linemark;
 802                 lines--;
 803             }
 804             break;
 805
 806         case FF_MORE:
 807             s = chophere;
 808             send = item + len;
 809             if (chopspace) {
 810                 while (*s && isSPACE(*s) && s < send)
 811                     s++;
 812             }
 813             if (s < send) {
 814                 arg = fieldsize - itemsize;
 815                 if (arg) {
 816                     fieldsize -= arg;
 817                     while (arg-- > 0)
 818                         *t++ = ' ';
 819                 }
 820                 s = t - 3;
 821                 if (strnEQ(s,"   ",3)) {
 822                     while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
 823                         s--;
 824                 }
 825                 *s++ = '.';
 826                 *s++ = '.';
 827                 *s++ = '.';
 828             }
 829             break;
 830
 831         case FF_END:
 832             *t = '\0';
 833             SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 834             if (targ_is_utf8)
 835                 SvUTF8_on(PL_formtarget);
 836             FmLINES(PL_formtarget) += lines;
 837             SP = ORIGMARK;
 838             RETPUSHYES;
 839         }
 840     }
 841 }
 842
 843 PP(pp_grepstart)
 844 {
 845     dSP;
 846     SV *src;
 847
 848     if (PL_stack_base + *PL_markstack_ptr == SP) {
 849         (void)POPMARK;
 850         if (GIMME_V == G_SCALAR)
 851             XPUSHs(sv_2mortal(newSViv(0)));
 852         RETURNOP(PL_op->op_next->op_next);
 853     }
 854     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 855     pp_pushmark();                              /* push dst */
 856     pp_pushmark();                              /* push src */
 857     ENTER;                                      /* enter outer scope */
 858
 859     SAVETMPS;
 860     /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
 861     SAVESPTR(DEFSV);
 862     ENTER;                                      /* enter inner scope */
 863     SAVEVPTR(PL_curpm);
 864
 865     src = PL_stack_base[*PL_markstack_ptr];
 866     SvTEMP_off(src);
 867     DEFSV = src;
 868
 869     PUTBACK;
 870     if (PL_op->op_type == OP_MAPSTART)
 871         pp_pushmark();                  /* push top */
 872     return ((LOGOP*)PL_op->op_next)->op_other;
 873 }
 874
 875 PP(pp_mapstart)
 876 {
 877     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 878 }
 879
 880 PP(pp_mapwhile)
 881 {
 882     dSP;
 883     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 884     I32 count;
 885     I32 shift;
 886     SV** src;
 887     SV** dst;
 888
 889     /* first, move source pointer to the next item in the source list */
 890     ++PL_markstack_ptr[-1];
 891
 892     /* if there are new items, push them into the destination list */
 893     if (items) {
 894         /* might need to make room back there first */
 895         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 896             /* XXX this implementation is very pessimal because the stack
 897              * is repeatedly extended for every set of items.  Is possible
 898              * to do this without any stack extension or copying at all
 899              * by maintaining a separate list over which the map iterates
 900              * (like foreach does). --gsar */
 901
 902             /* everything in the stack after the destination list moves
 903              * towards the end the stack by the amount of room needed */
 904             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 905
 906             /* items to shift up (accounting for the moved source pointer) */
 907             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 908
 909             /* This optimization is by Ben Tilly and it does
 910              * things differently from what Sarathy (gsar)
 911              * is describing.  The downside of this optimization is
 912              * that leaves "holes" (uninitialized and hopefully unused areas)
 913              * to the Perl stack, but on the other hand this
 914              * shouldn't be a problem.  If Sarathy's idea gets
 915              * implemented, this optimization should become
 916              * irrelevant.  --jhi */
 917             if (shift < count)
 918                 shift = count; /* Avoid shifting too often --Ben Tilly */
 919
 920             EXTEND(SP,shift);
 921             src = SP;
 922             dst = (SP += shift);
 923             PL_markstack_ptr[-1] += shift;
 924             *PL_markstack_ptr += shift;
 925             while (count--)
 926                 *dst-- = *src--;
 927         }
 928         /* copy the new items down to the destination list */
 929         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 930         while (items-- > 0)
 931             *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 932     }
 933     LEAVE;                                      /* exit inner scope */
 934
 935     /* All done yet? */
 936     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
 937         I32 gimme = GIMME_V;
 938
 939         (void)POPMARK;                          /* pop top */
 940         LEAVE;                                  /* exit outer scope */
 941         (void)POPMARK;                          /* pop src */
 942         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
 943         (void)POPMARK;                          /* pop dst */
 944         SP = PL_stack_base + POPMARK;           /* pop original mark */
 945         if (gimme == G_SCALAR) {
 946             dTARGET;
 947             XPUSHi(items);
 948         }
 949         else if (gimme == G_ARRAY)
 950             SP += items;
 951         RETURN;
 952     }
 953     else {
 954         SV *src;
 955
 956         ENTER;                                  /* enter inner scope */
 957         SAVEVPTR(PL_curpm);
 958
 959         /* set $_ to the new source item */
 960         src = PL_stack_base[PL_markstack_ptr[-1]];
 961         SvTEMP_off(src);
 962         DEFSV = src;
 963
 964         RETURNOP(cLOGOP->op_other);
 965     }
 966 }
 967
 968 /* Range stuff. */
 969
 970 PP(pp_range)
 971 {
 972     if (GIMME == G_ARRAY)
 973         return NORMAL;
 974     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
 975         return cLOGOP->op_other;
 976     else
 977         return NORMAL;
 978 }
 979
 980 PP(pp_flip)
 981 {
 982     dSP;
 983
 984     if (GIMME == G_ARRAY) {
 985         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 986     }
 987     else {
 988         dTOPss;
 989         SV *targ = PAD_SV(PL_op->op_targ);
 990         int flip = 0;
 991
 992         if (PL_op->op_private & OPpFLIP_LINENUM) {
 993             if (GvIO(PL_last_in_gv)) {
 994                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 995             }
 996             else {
 997                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
 998                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
 999             }
1000         } else {
1001             flip = SvTRUE(sv);
1002         }
1003         if (flip) {
1004             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1005             if (PL_op->op_flags & OPf_SPECIAL) {
1006                 sv_setiv(targ, 1);
1007                 SETs(targ);
1008                 RETURN;
1009             }
1010             else {
1011                 sv_setiv(targ, 0);
1012                 SP--;
1013                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1014             }
1015         }
1016         sv_setpv(TARG, "");
1017         SETs(targ);
1018         RETURN;
1019     }
1020 }
1021
1022 PP(pp_flop)
1023 {
1024     dSP;
1025
1026     if (GIMME == G_ARRAY) {
1027         dPOPPOPssrl;
1028         register I32 i, j;
1029         register SV *sv;
1030         I32 max;
1031
1032         if (SvGMAGICAL(left))
1033             mg_get(left);
1034         if (SvGMAGICAL(right))
1035             mg_get(right);
1036
1037         /* This code tries to decide if "$left .. $right" should use the
1038            magical string increment, or if the range is numeric (we make
1039            an exception for .."0" [#18165]). AMS 20021031. */
1040
1041         if (SvNIOKp(left) || !SvPOKp(left) ||
1042             SvNIOKp(right) || !SvPOKp(right) ||
1043             (looks_like_number(left) && *SvPVX(left) != '0' &&
1044              looks_like_number(right)))
1045         {
1046             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1047                 DIE(aTHX_ "Range iterator outside integer range");
1048             i = SvIV(left);
1049             max = SvIV(right);
1050             if (max >= i) {
1051                 j = max - i + 1;
1052                 EXTEND_MORTAL(j);
1053                 EXTEND(SP, j);
1054             }
1055             else
1056                 j = 0;
1057             while (j--) {
1058                 sv = sv_2mortal(newSViv(i++));
1059                 PUSHs(sv);
1060             }
1061         }
1062         else {
1063             SV *final = sv_mortalcopy(right);
1064             STRLEN len, n_a;
1065             char *tmps = SvPV(final, len);
1066
1067             sv = sv_mortalcopy(left);
1068             SvPV_force(sv,n_a);
1069             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1070                 XPUSHs(sv);
1071                 if (strEQ(SvPVX(sv),tmps))
1072                     break;
1073                 sv = sv_2mortal(newSVsv(sv));
1074                 sv_inc(sv);
1075             }
1076         }
1077     }
1078     else {
1079         dTOPss;
1080         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1081         int flop = 0;
1082         sv_inc(targ);
1083
1084         if (PL_op->op_private & OPpFLIP_LINENUM) {
1085             if (GvIO(PL_last_in_gv)) {
1086                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1087             }
1088             else {
1089                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1090                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1091             }
1092         }
1093         else {
1094             flop = SvTRUE(sv);
1095         }
1096
1097         if (flop) {
1098             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1099             sv_catpv(targ, "E0");
1100         }
1101         SETs(targ);
1102     }
1103
1104     RETURN;
1105 }
1106
1107 /* Control. */
1108
1109 static char *context_name[] = {
1110     "pseudo-block",
1111     "subroutine",
1112     "eval",
1113     "loop",
1114     "substitution",
1115     "block",
1116     "format"
1117 };
1118
1119 STATIC I32
1120 S_dopoptolabel(pTHX_ char *label)
1121 {
1122     register I32 i;
1123     register PERL_CONTEXT *cx;
1124
1125     for (i = cxstack_ix; i >= 0; i--) {
1126         cx = &cxstack[i];
1127         switch (CxTYPE(cx)) {
1128         case CXt_SUBST:
1129         case CXt_SUB:
1130         case CXt_FORMAT:
1131         case CXt_EVAL:
1132         case CXt_NULL:
1133             if (ckWARN(WARN_EXITING))
1134                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1135                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1136             if (CxTYPE(cx) == CXt_NULL)
1137                 return -1;
1138             break;
1139         case CXt_LOOP:
1140             if (!cx->blk_loop.label ||
1141               strNE(label, cx->blk_loop.label) ) {
1142                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1143                         (long)i, cx->blk_loop.label));
1144                 continue;
1145             }
1146             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1147             return i;
1148         }
1149     }
1150     return i;
1151 }
1152
1153 I32
1154 Perl_dowantarray(pTHX)
1155 {
1156     I32 gimme = block_gimme();
1157     return (gimme == G_VOID) ? G_SCALAR : gimme;
1158 }
1159
1160 I32
1161 Perl_block_gimme(pTHX)
1162 {
1163     I32 cxix;
1164
1165     cxix = dopoptosub(cxstack_ix);
1166     if (cxix < 0)
1167         return G_VOID;
1168
1169     switch (cxstack[cxix].blk_gimme) {
1170     case G_VOID:
1171         return G_VOID;
1172     case G_SCALAR:
1173         return G_SCALAR;
1174     case G_ARRAY:
1175         return G_ARRAY;
1176     default:
1177         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1178         /* NOTREACHED */
1179         return 0;
1180     }
1181 }
1182
1183 I32
1184 Perl_is_lvalue_sub(pTHX)
1185 {
1186     I32 cxix;
1187
1188     cxix = dopoptosub(cxstack_ix);
1189     assert(cxix >= 0);  /* We should only be called from inside subs */
1190
1191     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1192         return cxstack[cxix].blk_sub.lval;
1193     else
1194         return 0;
1195 }
1196
1197 STATIC I32
1198 S_dopoptosub(pTHX_ I32 startingblock)
1199 {
1200     return dopoptosub_at(cxstack, startingblock);
1201 }
1202
1203 STATIC I32
1204 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1205 {
1206     I32 i;
1207     register PERL_CONTEXT *cx;
1208     for (i = startingblock; i >= 0; i--) {
1209         cx = &cxstk[i];
1210         switch (CxTYPE(cx)) {
1211         default:
1212             continue;
1213         case CXt_EVAL:
1214         case CXt_SUB:
1215         case CXt_FORMAT:
1216             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1217             return i;
1218         }
1219     }
1220     return i;
1221 }
1222
1223 STATIC I32
1224 S_dopoptoeval(pTHX_ I32 startingblock)
1225 {
1226     I32 i;
1227     register PERL_CONTEXT *cx;
1228     for (i = startingblock; i >= 0; i--) {
1229         cx = &cxstack[i];
1230         switch (CxTYPE(cx)) {
1231         default:
1232             continue;
1233         case CXt_EVAL:
1234             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1235             return i;
1236         }
1237     }
1238     return i;
1239 }
1240
1241 STATIC I32
1242 S_dopoptoloop(pTHX_ I32 startingblock)
1243 {
1244     I32 i;
1245     register PERL_CONTEXT *cx;
1246     for (i = startingblock; i >= 0; i--) {
1247         cx = &cxstack[i];
1248         switch (CxTYPE(cx)) {
1249         case CXt_SUBST:
1250         case CXt_SUB:
1251         case CXt_FORMAT:
1252         case CXt_EVAL:
1253         case CXt_NULL:
1254             if (ckWARN(WARN_EXITING))
1255                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1256                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1257             if ((CxTYPE(cx)) == CXt_NULL)
1258                 return -1;
1259             break;
1260         case CXt_LOOP:
1261             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1262             return i;
1263         }
1264     }
1265     return i;
1266 }
1267
1268 void
1269 Perl_dounwind(pTHX_ I32 cxix)
1270 {
1271     register PERL_CONTEXT *cx;
1272     I32 optype;
1273
1274     while (cxstack_ix > cxix) {
1275         SV *sv;
1276         cx = &cxstack[cxstack_ix];
1277         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1278                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1279         /* Note: we don't need to restore the base context info till the end. */
1280         switch (CxTYPE(cx)) {
1281         case CXt_SUBST:
1282             POPSUBST(cx);
1283             continue;  /* not break */
1284         case CXt_SUB:
1285             POPSUB(cx,sv);
1286             LEAVESUB(sv);
1287             break;
1288         case CXt_EVAL:
1289             POPEVAL(cx);
1290             break;
1291         case CXt_LOOP:
1292             POPLOOP(cx);
1293             break;
1294         case CXt_NULL:
1295             break;
1296         case CXt_FORMAT:
1297             POPFORMAT(cx);
1298             break;
1299         }
1300         cxstack_ix--;
1301     }
1302 }
1303
1304 void
1305 Perl_qerror(pTHX_ SV *err)
1306 {
1307     if (PL_in_eval)
1308         sv_catsv(ERRSV, err);
1309     else if (PL_errors)
1310         sv_catsv(PL_errors, err);
1311     else
1312         Perl_warn(aTHX_ "%"SVf, err);
1313     ++PL_error_count;
1314 }
1315
1316 OP *
1317 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1318 {
1319     STRLEN n_a;
1320     IO *io;
1321     MAGIC *mg;
1322
1323     if (PL_in_eval) {
1324         I32 cxix;
1325         register PERL_CONTEXT *cx;
1326         I32 gimme;
1327         SV **newsp;
1328
1329         if (message) {
1330             if (PL_in_eval & EVAL_KEEPERR) {
1331                 static char prefix[] = "\t(in cleanup) ";
1332                 SV *err = ERRSV;
1333                 char *e = Nullch;
1334                 if (!SvPOK(err))
1335                     sv_setpv(err,"");
1336                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1337                     e = SvPV(err, n_a);
1338                     e += n_a - msglen;
1339                     if (*e != *message || strNE(e,message))
1340                         e = Nullch;
1341                 }
1342                 if (!e) {
1343                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1344                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1345                     sv_catpvn(err, message, msglen);
1346                     if (ckWARN(WARN_MISC)) {
1347                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1348                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1349                     }
1350                 }
1351             }
1352             else {
1353                 sv_setpvn(ERRSV, message, msglen);
1354             }
1355         }
1356         else
1357             message = SvPVx(ERRSV, msglen);
1358
1359         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1360                && PL_curstackinfo->si_prev)
1361         {
1362             dounwind(-1);
1363             POPSTACK;
1364         }
1365
1366         if (cxix >= 0) {
1367             I32 optype;
1368
1369             if (cxix < cxstack_ix)
1370                 dounwind(cxix);
1371
1372             POPBLOCK(cx,PL_curpm);
1373             if (CxTYPE(cx) != CXt_EVAL) {
1374                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1375                 PerlIO_write(Perl_error_log, message, msglen);
1376                 my_exit(1);
1377             }
1378             POPEVAL(cx);
1379
1380             if (gimme == G_SCALAR)
1381                 *++newsp = &PL_sv_undef;
1382             PL_stack_sp = newsp;
1383
1384             LEAVE;
1385
1386             /* LEAVE could clobber PL_curcop (see save_re_context())
1387              * XXX it might be better to find a way to avoid messing with
1388              * PL_curcop in save_re_context() instead, but this is a more
1389              * minimal fix --GSAR */
1390             PL_curcop = cx->blk_oldcop;
1391
1392             if (optype == OP_REQUIRE) {
1393                 char* msg = SvPVx(ERRSV, n_a);
1394                 DIE(aTHX_ "%sCompilation failed in require",
1395                     *msg ? msg : "Unknown error\n");
1396             }
1397             return pop_return();
1398         }
1399     }
1400     if (!message)
1401         message = SvPVx(ERRSV, msglen);
1402
1403     /* if STDERR is tied, print to it instead */
1404     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1405         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1406         dSP; ENTER;
1407         PUSHMARK(SP);
1408         XPUSHs(SvTIED_obj((SV*)io, mg));
1409         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1410         PUTBACK;
1411         call_method("PRINT", G_SCALAR);
1412         LEAVE;
1413     }
1414     else {
1415 #ifdef USE_SFIO
1416         /* SFIO can really mess with your errno */
1417         int e = errno;
1418 #endif
1419         PerlIO *serr = Perl_error_log;
1420
1421         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1422         (void)PerlIO_flush(serr);
1423 #ifdef USE_SFIO
1424         errno = e;
1425 #endif
1426     }
1427     my_failure_exit();
1428     /* NOTREACHED */
1429     return 0;
1430 }
1431
1432 PP(pp_xor)
1433 {
1434     dSP; dPOPTOPssrl;
1435     if (SvTRUE(left) != SvTRUE(right))
1436         RETSETYES;
1437     else
1438         RETSETNO;
1439 }
1440
1441 PP(pp_andassign)
1442 {
1443     dSP;
1444     if (!SvTRUE(TOPs))
1445         RETURN;
1446     else
1447         RETURNOP(cLOGOP->op_other);
1448 }
1449
1450 PP(pp_orassign)
1451 {
1452     dSP;
1453     if (SvTRUE(TOPs))
1454         RETURN;
1455     else
1456         RETURNOP(cLOGOP->op_other);
1457 }
1458
1459 PP(pp_dorassign)
1460 {
1461     dSP;
1462     register SV* sv;
1463
1464     sv = TOPs;
1465     if (!sv || !SvANY(sv)) {
1466         RETURNOP(cLOGOP->op_other);
1467     }
1468
1469     switch (SvTYPE(sv)) {
1470     case SVt_PVAV:
1471         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1472             RETURN;
1473         break;
1474     case SVt_PVHV:
1475         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1476             RETURN;
1477         break;
1478     case SVt_PVCV:
1479         if (CvROOT(sv) || CvXSUB(sv))
1480             RETURN;
1481         break;
1482     default:
1483         if (SvGMAGICAL(sv))
1484             mg_get(sv);
1485         if (SvOK(sv))
1486             RETURN;
1487     }
1488
1489     RETURNOP(cLOGOP->op_other);
1490 }
1491
1492 PP(pp_caller)
1493 {
1494     dSP;
1495     register I32 cxix = dopoptosub(cxstack_ix);
1496     register PERL_CONTEXT *cx;
1497     register PERL_CONTEXT *ccstack = cxstack;
1498     PERL_SI *top_si = PL_curstackinfo;
1499     I32 dbcxix;
1500     I32 gimme;
1501     char *stashname;
1502     SV *sv;
1503     I32 count = 0;
1504
1505     if (MAXARG)
1506         count = POPi;
1507
1508     for (;;) {
1509         /* we may be in a higher stacklevel, so dig down deeper */
1510         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1511             top_si = top_si->si_prev;
1512             ccstack = top_si->si_cxstack;
1513             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1514         }
1515         if (cxix < 0) {
1516             if (GIMME != G_ARRAY) {
1517                 EXTEND(SP, 1);
1518                 RETPUSHUNDEF;
1519             }
1520             RETURN;
1521         }
1522         if (PL_DBsub && cxix >= 0 &&
1523                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1524             count++;
1525         if (!count--)
1526             break;
1527         cxix = dopoptosub_at(ccstack, cxix - 1);
1528     }
1529
1530     cx = &ccstack[cxix];
1531     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1532         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1533         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1534            field below is defined for any cx. */
1535         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1536             cx = &ccstack[dbcxix];
1537     }
1538
1539     stashname = CopSTASHPV(cx->blk_oldcop);
1540     if (GIMME != G_ARRAY) {
1541         EXTEND(SP, 1);
1542         if (!stashname)
1543             PUSHs(&PL_sv_undef);
1544         else {
1545             dTARGET;
1546             sv_setpv(TARG, stashname);
1547             PUSHs(TARG);
1548         }
1549         RETURN;
1550     }
1551
1552     EXTEND(SP, 10);
1553
1554     if (!stashname)
1555         PUSHs(&PL_sv_undef);
1556     else
1557         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1558     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1559     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1560     if (!MAXARG)
1561         RETURN;
1562     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1563         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1564         /* So is ccstack[dbcxix]. */
1565         if (isGV(cvgv)) {
1566             sv = NEWSV(49, 0);
1567             gv_efullname3(sv, cvgv, Nullch);
1568             PUSHs(sv_2mortal(sv));
1569             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1570         }
1571         else {
1572             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1573             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1574         }
1575     }
1576     else {
1577         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1578         PUSHs(sv_2mortal(newSViv(0)));
1579     }
1580     gimme = (I32)cx->blk_gimme;
1581     if (gimme == G_VOID)
1582         PUSHs(&PL_sv_undef);
1583     else
1584         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1585     if (CxTYPE(cx) == CXt_EVAL) {
1586         /* eval STRING */
1587         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1588             PUSHs(cx->blk_eval.cur_text);
1589             PUSHs(&PL_sv_no);
1590         }
1591         /* require */
1592         else if (cx->blk_eval.old_namesv) {
1593             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1594             PUSHs(&PL_sv_yes);
1595         }
1596         /* eval BLOCK (try blocks have old_namesv == 0) */
1597         else {
1598             PUSHs(&PL_sv_undef);
1599             PUSHs(&PL_sv_undef);
1600         }
1601     }
1602     else {
1603         PUSHs(&PL_sv_undef);
1604         PUSHs(&PL_sv_undef);
1605     }
1606     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1607         && CopSTASH_eq(PL_curcop, PL_debstash))
1608     {
1609         AV *ary = cx->blk_sub.argarray;
1610         int off = AvARRAY(ary) - AvALLOC(ary);
1611
1612         if (!PL_dbargs) {
1613             GV* tmpgv;
1614             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1615                                 SVt_PVAV)));
1616             GvMULTI_on(tmpgv);
1617             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1618         }
1619
1620         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1621             av_extend(PL_dbargs, AvFILLp(ary) + off);
1622         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1623         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1624     }
1625     /* XXX only hints propagated via op_private are currently
1626      * visible (others are not easily accessible, since they
1627      * use the global PL_hints) */
1628     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1629                              HINT_PRIVATE_MASK)));
1630     {
1631         SV * mask ;
1632         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1633
1634         if  (old_warnings == pWARN_NONE ||
1635                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1636             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1637         else if (old_warnings == pWARN_ALL ||
1638                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1639             /* Get the bit mask for $warnings::Bits{all}, because
1640              * it could have been extended by warnings::register */
1641             SV **bits_all;
1642             HV *bits = get_hv("warnings::Bits", FALSE);
1643             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1644                 mask = newSVsv(*bits_all);
1645             }
1646             else {
1647                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1648             }
1649         }
1650         else
1651             mask = newSVsv(old_warnings);
1652         PUSHs(sv_2mortal(mask));
1653     }
1654     RETURN;
1655 }
1656
1657 PP(pp_reset)
1658 {
1659     dSP;
1660     char *tmps;
1661     STRLEN n_a;
1662
1663     if (MAXARG < 1)
1664         tmps = "";
1665     else
1666         tmps = POPpx;
1667     sv_reset(tmps, CopSTASH(PL_curcop));
1668     PUSHs(&PL_sv_yes);
1669     RETURN;
1670 }
1671
1672 PP(pp_lineseq)
1673 {
1674     return NORMAL;
1675 }
1676
1677 /* like pp_nextstate, but used instead when the debugger is active */
1678
1679 PP(pp_dbstate)
1680 {
1681     PL_curcop = (COP*)PL_op;
1682     TAINT_NOT;          /* Each statement is presumed innocent */
1683     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1684     FREETMPS;
1685
1686     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1687             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1688     {
1689         dSP;
1690         register CV *cv;
1691         register PERL_CONTEXT *cx;
1692         I32 gimme = G_ARRAY;
1693         U8 hasargs;
1694         GV *gv;
1695
1696         gv = PL_DBgv;
1697         cv = GvCV(gv);
1698         if (!cv)
1699             DIE(aTHX_ "No DB::DB routine defined");
1700
1701         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1702             /* don't do recursive DB::DB call */
1703             return NORMAL;
1704
1705         ENTER;
1706         SAVETMPS;
1707
1708         SAVEI32(PL_debug);
1709         SAVESTACK_POS();
1710         PL_debug = 0;
1711         hasargs = 0;
1712         SPAGAIN;
1713
1714         push_return(PL_op->op_next);
1715         PUSHBLOCK(cx, CXt_SUB, SP);
1716         PUSHSUB_DB(cx);
1717         CvDEPTH(cv)++;
1718         (void)SvREFCNT_inc(cv);
1719         PAD_SET_CUR(CvPADLIST(cv),1);
1720         RETURNOP(CvSTART(cv));
1721     }
1722     else
1723         return NORMAL;
1724 }
1725
1726 PP(pp_scope)
1727 {
1728     return NORMAL;
1729 }
1730
1731 PP(pp_enteriter)
1732 {
1733     dSP; dMARK;
1734     register PERL_CONTEXT *cx;
1735     I32 gimme = GIMME_V;
1736     SV **svp;
1737     U32 cxtype = CXt_LOOP;
1738 #ifdef USE_ITHREADS
1739     void *iterdata;
1740 #endif
1741
1742     ENTER;
1743     SAVETMPS;
1744
1745     if (PL_op->op_targ) {
1746 #ifndef USE_ITHREADS
1747         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1748         SAVESPTR(*svp);
1749 #else
1750         SAVEPADSV(PL_op->op_targ);
1751         iterdata = INT2PTR(void*, PL_op->op_targ);
1752         cxtype |= CXp_PADVAR;
1753 #endif
1754     }
1755     else {
1756         GV *gv = (GV*)POPs;
1757         svp = &GvSV(gv);                        /* symbol table variable */
1758         SAVEGENERICSV(*svp);
1759         *svp = NEWSV(0,0);
1760 #ifdef USE_ITHREADS
1761         iterdata = (void*)gv;
1762 #endif
1763     }
1764
1765     ENTER;
1766
1767     PUSHBLOCK(cx, cxtype, SP);
1768 #ifdef USE_ITHREADS
1769     PUSHLOOP(cx, iterdata, MARK);
1770 #else
1771     PUSHLOOP(cx, svp, MARK);
1772 #endif
1773     if (PL_op->op_flags & OPf_STACKED) {
1774         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1775         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1776             dPOPss;
1777             /* See comment in pp_flop() */
1778             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1779                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1780                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1781                  looks_like_number((SV*)cx->blk_loop.iterary)))
1782             {
1783                  if (SvNV(sv) < IV_MIN ||
1784                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1785                      DIE(aTHX_ "Range iterator outside integer range");
1786                  cx->blk_loop.iterix = SvIV(sv);
1787                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1788             }
1789             else
1790                 cx->blk_loop.iterlval = newSVsv(sv);
1791         }
1792     }
1793     else {
1794         cx->blk_loop.iterary = PL_curstack;
1795         AvFILLp(PL_curstack) = SP - PL_stack_base;
1796         cx->blk_loop.iterix = MARK - PL_stack_base;
1797     }
1798
1799     RETURN;
1800 }
1801
1802 PP(pp_enterloop)
1803 {
1804     dSP;
1805     register PERL_CONTEXT *cx;
1806     I32 gimme = GIMME_V;
1807
1808     ENTER;
1809     SAVETMPS;
1810     ENTER;
1811
1812     PUSHBLOCK(cx, CXt_LOOP, SP);
1813     PUSHLOOP(cx, 0, SP);
1814
1815     RETURN;
1816 }
1817
1818 PP(pp_leaveloop)
1819 {
1820     dSP;
1821     register PERL_CONTEXT *cx;
1822     I32 gimme;
1823     SV **newsp;
1824     PMOP *newpm;
1825     SV **mark;
1826
1827     POPBLOCK(cx,newpm);
1828     mark = newsp;
1829     newsp = PL_stack_base + cx->blk_loop.resetsp;
1830
1831     TAINT_NOT;
1832     if (gimme == G_VOID)
1833         ; /* do nothing */
1834     else if (gimme == G_SCALAR) {
1835         if (mark < SP)
1836             *++newsp = sv_mortalcopy(*SP);
1837         else
1838             *++newsp = &PL_sv_undef;
1839     }
1840     else {
1841         while (mark < SP) {
1842             *++newsp = sv_mortalcopy(*++mark);
1843             TAINT_NOT;          /* Each item is independent */
1844         }
1845     }
1846     SP = newsp;
1847     PUTBACK;
1848
1849     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1850     PL_curpm = newpm;   /* ... and pop $1 et al */
1851
1852     LEAVE;
1853     LEAVE;
1854
1855     return NORMAL;
1856 }
1857
1858 PP(pp_return)
1859 {
1860     dSP; dMARK;
1861     I32 cxix;
1862     register PERL_CONTEXT *cx;
1863     bool popsub2 = FALSE;
1864     bool clear_errsv = FALSE;
1865     I32 gimme;
1866     SV **newsp;
1867     PMOP *newpm;
1868     I32 optype = 0;
1869     SV *sv;
1870
1871     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1872         if (cxstack_ix == PL_sortcxix
1873             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1874         {
1875             if (cxstack_ix > PL_sortcxix)
1876                 dounwind(PL_sortcxix);
1877             AvARRAY(PL_curstack)[1] = *SP;
1878             PL_stack_sp = PL_stack_base + 1;
1879             return 0;
1880         }
1881     }
1882
1883     cxix = dopoptosub(cxstack_ix);
1884     if (cxix < 0)
1885         DIE(aTHX_ "Can't return outside a subroutine");
1886     if (cxix < cxstack_ix)
1887         dounwind(cxix);
1888
1889     POPBLOCK(cx,newpm);
1890     switch (CxTYPE(cx)) {
1891     case CXt_SUB:
1892         popsub2 = TRUE;
1893         break;
1894     case CXt_EVAL:
1895         if (!(PL_in_eval & EVAL_KEEPERR))
1896             clear_errsv = TRUE;
1897         POPEVAL(cx);
1898         if (CxTRYBLOCK(cx))
1899             break;
1900         lex_end();
1901         if (optype == OP_REQUIRE &&
1902             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1903         {
1904             /* Unassume the success we assumed earlier. */
1905             SV *nsv = cx->blk_eval.old_namesv;
1906             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1907             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1908         }
1909         break;
1910     case CXt_FORMAT:
1911         POPFORMAT(cx);
1912         break;
1913     default:
1914         DIE(aTHX_ "panic: return");
1915     }
1916
1917     TAINT_NOT;
1918     if (gimme == G_SCALAR) {
1919         if (MARK < SP) {
1920             if (popsub2) {
1921                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1922                     if (SvTEMP(TOPs)) {
1923                         *++newsp = SvREFCNT_inc(*SP);
1924                         FREETMPS;
1925                         sv_2mortal(*newsp);
1926                     }
1927                     else {
1928                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1929                         FREETMPS;
1930                         *++newsp = sv_mortalcopy(sv);
1931                         SvREFCNT_dec(sv);
1932                     }
1933                 }
1934                 else
1935                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1936             }
1937             else
1938                 *++newsp = sv_mortalcopy(*SP);
1939         }
1940         else
1941             *++newsp = &PL_sv_undef;
1942     }
1943     else if (gimme == G_ARRAY) {
1944         while (++MARK <= SP) {
1945             *++newsp = (popsub2 && SvTEMP(*MARK))
1946                         ? *MARK : sv_mortalcopy(*MARK);
1947             TAINT_NOT;          /* Each item is independent */
1948         }
1949     }
1950     PL_stack_sp = newsp;
1951
1952     /* Stack values are safe: */
1953     if (popsub2) {
1954         POPSUB(cx,sv);  /* release CV and @_ ... */
1955     }
1956     else
1957         sv = Nullsv;
1958     PL_curpm = newpm;   /* ... and pop $1 et al */
1959
1960     LEAVE;
1961     LEAVESUB(sv);
1962     if (clear_errsv)
1963         sv_setpv(ERRSV,"");
1964     return pop_return();
1965 }
1966
1967 PP(pp_last)
1968 {
1969     dSP;
1970     I32 cxix;
1971     register PERL_CONTEXT *cx;
1972     I32 pop2 = 0;
1973     I32 gimme;
1974     I32 optype;
1975     OP *nextop;
1976     SV **newsp;
1977     PMOP *newpm;
1978     SV **mark;
1979     SV *sv = Nullsv;
1980
1981     if (PL_op->op_flags & OPf_SPECIAL) {
1982         cxix = dopoptoloop(cxstack_ix);
1983         if (cxix < 0)
1984             DIE(aTHX_ "Can't \"last\" outside a loop block");
1985     }
1986     else {
1987         cxix = dopoptolabel(cPVOP->op_pv);
1988         if (cxix < 0)
1989             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1990     }
1991     if (cxix < cxstack_ix)
1992         dounwind(cxix);
1993
1994     POPBLOCK(cx,newpm);
1995     mark = newsp;
1996     switch (CxTYPE(cx)) {
1997     case CXt_LOOP:
1998         pop2 = CXt_LOOP;
1999         newsp = PL_stack_base + cx->blk_loop.resetsp;
2000         nextop = cx->blk_loop.last_op->op_next;
2001         break;
2002     case CXt_SUB:
2003         pop2 = CXt_SUB;
2004         nextop = pop_return();
2005         break;
2006     case CXt_EVAL:
2007         POPEVAL(cx);
2008         nextop = pop_return();
2009         break;
2010     case CXt_FORMAT:
2011         POPFORMAT(cx);
2012         nextop = pop_return();
2013         break;
2014     default:
2015         DIE(aTHX_ "panic: last");
2016     }
2017
2018     TAINT_NOT;
2019     if (gimme == G_SCALAR) {
2020         if (MARK < SP)
2021             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2022                         ? *SP : sv_mortalcopy(*SP);
2023         else
2024             *++newsp = &PL_sv_undef;
2025     }
2026     else if (gimme == G_ARRAY) {
2027         while (++MARK <= SP) {
2028             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2029                         ? *MARK : sv_mortalcopy(*MARK);
2030             TAINT_NOT;          /* Each item is independent */
2031         }
2032     }
2033     SP = newsp;
2034     PUTBACK;
2035
2036     /* Stack values are safe: */
2037     switch (pop2) {
2038     case CXt_LOOP:
2039         POPLOOP(cx);    /* release loop vars ... */
2040         LEAVE;
2041         break;
2042     case CXt_SUB:
2043         POPSUB(cx,sv);  /* release CV and @_ ... */
2044         break;
2045     }
2046     PL_curpm = newpm;   /* ... and pop $1 et al */
2047
2048     LEAVE;
2049     LEAVESUB(sv);
2050     return nextop;
2051 }
2052
2053 PP(pp_next)
2054 {
2055     I32 cxix;
2056     register PERL_CONTEXT *cx;
2057     I32 inner;
2058
2059     if (PL_op->op_flags & OPf_SPECIAL) {
2060         cxix = dopoptoloop(cxstack_ix);
2061         if (cxix < 0)
2062             DIE(aTHX_ "Can't \"next\" outside a loop block");
2063     }
2064     else {
2065         cxix = dopoptolabel(cPVOP->op_pv);
2066         if (cxix < 0)
2067             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2068     }
2069     if (cxix < cxstack_ix)
2070         dounwind(cxix);
2071
2072     /* clear off anything above the scope we're re-entering, but
2073      * save the rest until after a possible continue block */
2074     inner = PL_scopestack_ix;
2075     TOPBLOCK(cx);
2076     if (PL_scopestack_ix < inner)
2077         leave_scope(PL_scopestack[PL_scopestack_ix]);
2078     return cx->blk_loop.next_op;
2079 }
2080
2081 PP(pp_redo)
2082 {
2083     I32 cxix;
2084     register PERL_CONTEXT *cx;
2085     I32 oldsave;
2086
2087     if (PL_op->op_flags & OPf_SPECIAL) {
2088         cxix = dopoptoloop(cxstack_ix);
2089         if (cxix < 0)
2090             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2091     }
2092     else {
2093         cxix = dopoptolabel(cPVOP->op_pv);
2094         if (cxix < 0)
2095             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2096     }
2097     if (cxix < cxstack_ix)
2098         dounwind(cxix);
2099
2100     TOPBLOCK(cx);
2101     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2102     LEAVE_SCOPE(oldsave);
2103     return cx->blk_loop.redo_op;
2104 }
2105
2106 STATIC OP *
2107 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2108 {
2109     OP *kid = Nullop;
2110     OP **ops = opstack;
2111     static char too_deep[] = "Target of goto is too deeply nested";
2112
2113     if (ops >= oplimit)
2114         Perl_croak(aTHX_ too_deep);
2115     if (o->op_type == OP_LEAVE ||
2116         o->op_type == OP_SCOPE ||
2117         o->op_type == OP_LEAVELOOP ||
2118         o->op_type == OP_LEAVESUB ||
2119         o->op_type == OP_LEAVETRY)
2120     {
2121         *ops++ = cUNOPo->op_first;
2122         if (ops >= oplimit)
2123             Perl_croak(aTHX_ too_deep);
2124     }
2125     *ops = 0;
2126     if (o->op_flags & OPf_KIDS) {
2127         /* First try all the kids at this level, since that's likeliest. */
2128         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2129             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2130                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2131                 return kid;
2132         }
2133         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2134             if (kid == PL_lastgotoprobe)
2135                 continue;
2136             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2137                 if (ops == opstack)
2138                     *ops++ = kid;
2139                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2140                          ops[-1]->op_type == OP_DBSTATE)
2141                     ops[-1] = kid;
2142                 else
2143                     *ops++ = kid;
2144             }
2145             if ((o = dofindlabel(kid, label, ops, oplimit)))
2146                 return o;
2147         }
2148     }
2149     *ops = 0;
2150     return 0;
2151 }
2152
2153 PP(pp_dump)
2154 {
2155     return pp_goto();
2156     /*NOTREACHED*/
2157 }
2158
2159 PP(pp_goto)
2160 {
2161     dSP;
2162     OP *retop = 0;
2163     I32 ix;
2164     register PERL_CONTEXT *cx;
2165 #define GOTO_DEPTH 64
2166     OP *enterops[GOTO_DEPTH];
2167     char *label;
2168     int do_dump = (PL_op->op_type == OP_DUMP);
2169     static char must_have_label[] = "goto must have label";
2170
2171     label = 0;
2172     if (PL_op->op_flags & OPf_STACKED) {
2173         SV *sv = POPs;
2174         STRLEN n_a;
2175
2176         /* This egregious kludge implements goto &subroutine */
2177         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2178             I32 cxix;
2179             register PERL_CONTEXT *cx;
2180             CV* cv = (CV*)SvRV(sv);
2181             SV** mark;
2182             I32 items = 0;
2183             I32 oldsave;
2184
2185         retry:
2186             if (!CvROOT(cv) && !CvXSUB(cv)) {
2187                 GV *gv = CvGV(cv);
2188                 GV *autogv;
2189                 if (gv) {
2190                     SV *tmpstr;
2191                     /* autoloaded stub? */
2192                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2193                         goto retry;
2194                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2195                                           GvNAMELEN(gv), FALSE);
2196                     if (autogv && (cv = GvCV(autogv)))
2197                         goto retry;
2198                     tmpstr = sv_newmortal();
2199                     gv_efullname3(tmpstr, gv, Nullch);
2200                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2201                 }
2202                 DIE(aTHX_ "Goto undefined subroutine");
2203             }
2204
2205             /* First do some returnish stuff. */
2206             FREETMPS;
2207             cxix = dopoptosub(cxstack_ix);
2208             if (cxix < 0)
2209                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2210             if (cxix < cxstack_ix)
2211                 dounwind(cxix);
2212             TOPBLOCK(cx);
2213             if (CxREALEVAL(cx))
2214                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2215             mark = PL_stack_sp;
2216             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2217                 /* put @_ back onto stack */
2218                 AV* av = cx->blk_sub.argarray;
2219
2220                 items = AvFILLp(av) + 1;
2221                 PL_stack_sp++;
2222                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2223                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2224                 PL_stack_sp += items;
2225                 SvREFCNT_dec(GvAV(PL_defgv));
2226                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2227                 /* abandon @_ if it got reified */
2228                 if (AvREAL(av)) {
2229                     (void)sv_2mortal((SV*)av);  /* delay until return */
2230                     av = newAV();
2231                     av_extend(av, items-1);
2232                     AvFLAGS(av) = AVf_REIFY;
2233                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2234                 }
2235             }
2236             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2237                 AV* av;
2238                 av = GvAV(PL_defgv);
2239                 items = AvFILLp(av) + 1;
2240                 PL_stack_sp++;
2241                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2242                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2243                 PL_stack_sp += items;
2244             }
2245             if (CxTYPE(cx) == CXt_SUB &&
2246                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2247                 SvREFCNT_dec(cx->blk_sub.cv);
2248             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2249             LEAVE_SCOPE(oldsave);
2250
2251             /* Now do some callish stuff. */
2252             SAVETMPS;
2253             if (CvXSUB(cv)) {
2254 #ifdef PERL_XSUB_OLDSTYLE
2255                 if (CvOLDSTYLE(cv)) {
2256                     I32 (*fp3)(int,int,int);
2257                     while (SP > mark) {
2258                         SP[1] = SP[0];
2259                         SP--;
2260                     }
2261                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2262                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2263                                    mark - PL_stack_base + 1,
2264                                    items);
2265                     SP = PL_stack_base + items;
2266                 }
2267                 else
2268 #endif /* PERL_XSUB_OLDSTYLE */
2269                 {
2270                     SV **newsp;
2271                     I32 gimme;
2272
2273                     PL_stack_sp--;              /* There is no cv arg. */
2274                     /* Push a mark for the start of arglist */
2275                     PUSHMARK(mark);
2276                     (void)(*CvXSUB(cv))(aTHX_ cv);
2277                     /* Pop the current context like a decent sub should */
2278                     POPBLOCK(cx, PL_curpm);
2279                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2280                 }
2281                 LEAVE;
2282                 return pop_return();
2283             }
2284             else {
2285                 AV* padlist = CvPADLIST(cv);
2286                 if (CxTYPE(cx) == CXt_EVAL) {
2287                     PL_in_eval = cx->blk_eval.old_in_eval;
2288                     PL_eval_root = cx->blk_eval.old_eval_root;
2289                     cx->cx_type = CXt_SUB;
2290                     cx->blk_sub.hasargs = 0;
2291                 }
2292                 cx->blk_sub.cv = cv;
2293                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2294
2295                 CvDEPTH(cv)++;
2296                 if (CvDEPTH(cv) < 2)
2297                     (void)SvREFCNT_inc(cv);
2298                 else {
2299                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2300                         sub_crush_depth(cv);
2301                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2302                 }
2303                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2304                 if (cx->blk_sub.hasargs)
2305                 {
2306                     AV* av = (AV*)PAD_SVl(0);
2307                     SV** ary;
2308
2309                     cx->blk_sub.savearray = GvAV(PL_defgv);
2310                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2311                     CX_CURPAD_SAVE(cx->blk_sub);
2312                     cx->blk_sub.argarray = av;
2313                     ++mark;
2314
2315                     if (items >= AvMAX(av) + 1) {
2316                         ary = AvALLOC(av);
2317                         if (AvARRAY(av) != ary) {
2318                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2319                             SvPVX(av) = (char*)ary;
2320                         }
2321                         if (items >= AvMAX(av) + 1) {
2322                             AvMAX(av) = items - 1;
2323                             Renew(ary,items+1,SV*);
2324                             AvALLOC(av) = ary;
2325                             SvPVX(av) = (char*)ary;
2326                         }
2327                     }
2328                     Copy(mark,AvARRAY(av),items,SV*);
2329                     AvFILLp(av) = items - 1;
2330                     assert(!AvREAL(av));
2331                     while (items--) {
2332                         if (*mark)
2333                             SvTEMP_off(*mark);
2334                         mark++;
2335                     }
2336                 }
2337                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2338                     /*
2339                      * We do not care about using sv to call CV;
2340                      * it's for informational purposes only.
2341                      */
2342                     SV *sv = GvSV(PL_DBsub);
2343                     CV *gotocv;
2344
2345                     if (PERLDB_SUB_NN) {
2346                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2347                     } else {
2348                         save_item(sv);
2349                         gv_efullname3(sv, CvGV(cv), Nullch);
2350                     }
2351                     if (  PERLDB_GOTO
2352                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2353                         PUSHMARK( PL_stack_sp );
2354                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2355                         PL_stack_sp--;
2356                     }
2357                 }
2358                 RETURNOP(CvSTART(cv));
2359             }
2360         }
2361         else {
2362             label = SvPV(sv,n_a);
2363             if (!(do_dump || *label))
2364                 DIE(aTHX_ must_have_label);
2365         }
2366     }
2367     else if (PL_op->op_flags & OPf_SPECIAL) {
2368         if (! do_dump)
2369             DIE(aTHX_ must_have_label);
2370     }
2371     else
2372         label = cPVOP->op_pv;
2373
2374     if (label && *label) {
2375         OP *gotoprobe = 0;
2376         bool leaving_eval = FALSE;
2377         bool in_block = FALSE;
2378         PERL_CONTEXT *last_eval_cx = 0;
2379
2380         /* find label */
2381
2382         PL_lastgotoprobe = 0;
2383         *enterops = 0;
2384         for (ix = cxstack_ix; ix >= 0; ix--) {
2385             cx = &cxstack[ix];
2386             switch (CxTYPE(cx)) {
2387             case CXt_EVAL:
2388                 leaving_eval = TRUE;
2389                 if (CxREALEVAL(cx)) {
2390                     gotoprobe = (last_eval_cx ?
2391                                 last_eval_cx->blk_eval.old_eval_root :
2392                                 PL_eval_root);
2393                     last_eval_cx = cx;
2394                     break;
2395                 }
2396                 /* else fall through */
2397             case CXt_LOOP:
2398                 gotoprobe = cx->blk_oldcop->op_sibling;
2399                 break;
2400             case CXt_SUBST:
2401                 continue;
2402             case CXt_BLOCK:
2403                 if (ix) {
2404                     gotoprobe = cx->blk_oldcop->op_sibling;
2405                     in_block = TRUE;
2406                 } else
2407                     gotoprobe = PL_main_root;
2408                 break;
2409             case CXt_SUB:
2410                 if (CvDEPTH(cx->blk_sub.cv)) {
2411                     gotoprobe = CvROOT(cx->blk_sub.cv);
2412                     break;
2413                 }
2414                 /* FALL THROUGH */
2415             case CXt_FORMAT:
2416             case CXt_NULL:
2417                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2418             default:
2419                 if (ix)
2420                     DIE(aTHX_ "panic: goto");
2421                 gotoprobe = PL_main_root;
2422                 break;
2423             }
2424             if (gotoprobe) {
2425                 retop = dofindlabel(gotoprobe, label,
2426                                     enterops, enterops + GOTO_DEPTH);
2427                 if (retop)
2428                     break;
2429             }
2430             PL_lastgotoprobe = gotoprobe;
2431         }
2432         if (!retop)
2433             DIE(aTHX_ "Can't find label %s", label);
2434
2435         /* if we're leaving an eval, check before we pop any frames
2436            that we're not going to punt, otherwise the error
2437            won't be caught */
2438
2439         if (leaving_eval && *enterops && enterops[1]) {
2440             I32 i;
2441             for (i = 1; enterops[i]; i++)
2442                 if (enterops[i]->op_type == OP_ENTERITER)
2443                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2444         }
2445
2446         /* pop unwanted frames */
2447
2448         if (ix < cxstack_ix) {
2449             I32 oldsave;
2450
2451             if (ix < 0)
2452                 ix = 0;
2453             dounwind(ix);
2454             TOPBLOCK(cx);
2455             oldsave = PL_scopestack[PL_scopestack_ix];
2456             LEAVE_SCOPE(oldsave);
2457         }
2458
2459         /* push wanted frames */
2460
2461         if (*enterops && enterops[1]) {
2462             OP *oldop = PL_op;
2463             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2464             for (; enterops[ix]; ix++) {
2465                 PL_op = enterops[ix];
2466                 /* Eventually we may want to stack the needed arguments
2467                  * for each op.  For now, we punt on the hard ones. */
2468                 if (PL_op->op_type == OP_ENTERITER)
2469                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2470                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2471             }
2472             PL_op = oldop;
2473         }
2474     }
2475
2476     if (do_dump) {
2477 #ifdef VMS
2478         if (!retop) retop = PL_main_start;
2479 #endif
2480         PL_restartop = retop;
2481         PL_do_undump = TRUE;
2482
2483         my_unexec();
2484
2485         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2486         PL_do_undump = FALSE;
2487     }
2488
2489     RETURNOP(retop);
2490 }
2491
2492 PP(pp_exit)
2493 {
2494     dSP;
2495     I32 anum;
2496
2497     if (MAXARG < 1)
2498         anum = 0;
2499     else {
2500         anum = SvIVx(POPs);
2501 #ifdef VMS
2502         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2503             anum = 0;
2504         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2505 #endif
2506     }
2507     PL_exit_flags |= PERL_EXIT_EXPECTED;
2508     my_exit(anum);
2509     PUSHs(&PL_sv_undef);
2510     RETURN;
2511 }
2512
2513 #ifdef NOTYET
2514 PP(pp_nswitch)
2515 {
2516     dSP;
2517     NV value = SvNVx(GvSV(cCOP->cop_gv));
2518     register I32 match = I_32(value);
2519
2520     if (value < 0.0) {
2521         if (((NV)match) > value)
2522             --match;            /* was fractional--truncate other way */
2523     }
2524     match -= cCOP->uop.scop.scop_offset;
2525     if (match < 0)
2526         match = 0;
2527     else if (match > cCOP->uop.scop.scop_max)
2528         match = cCOP->uop.scop.scop_max;
2529     PL_op = cCOP->uop.scop.scop_next[match];
2530     RETURNOP(PL_op);
2531 }
2532
2533 PP(pp_cswitch)
2534 {
2535     dSP;
2536     register I32 match;
2537
2538     if (PL_multiline)
2539         PL_op = PL_op->op_next;                 /* can't assume anything */
2540     else {
2541         STRLEN n_a;
2542         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2543         match -= cCOP->uop.scop.scop_offset;
2544         if (match < 0)
2545             match = 0;
2546         else if (match > cCOP->uop.scop.scop_max)
2547             match = cCOP->uop.scop.scop_max;
2548         PL_op = cCOP->uop.scop.scop_next[match];
2549     }
2550     RETURNOP(PL_op);
2551 }
2552 #endif
2553
2554 /* Eval. */
2555
2556 STATIC void
2557 S_save_lines(pTHX_ AV *array, SV *sv)
2558 {
2559     register char *s = SvPVX(sv);
2560     register char *send = SvPVX(sv) + SvCUR(sv);
2561     register char *t;
2562     register I32 line = 1;
2563
2564     while (s && s < send) {
2565         SV *tmpstr = NEWSV(85,0);
2566
2567         sv_upgrade(tmpstr, SVt_PVMG);
2568         t = strchr(s, '\n');
2569         if (t)
2570             t++;
2571         else
2572             t = send;
2573
2574         sv_setpvn(tmpstr, s, t - s);
2575         av_store(array, line++, tmpstr);
2576         s = t;
2577     }
2578 }
2579
2580 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2581 STATIC void *
2582 S_docatch_body(pTHX_ va_list args)
2583 {
2584     return docatch_body();
2585 }
2586 #endif
2587
2588 STATIC void *
2589 S_docatch_body(pTHX)
2590 {
2591     CALLRUNOPS(aTHX);
2592     return NULL;
2593 }
2594
2595 STATIC OP *
2596 S_docatch(pTHX_ OP *o)
2597 {
2598     int ret;
2599     OP *oldop = PL_op;
2600     OP *retop;
2601     volatile PERL_SI *cursi = PL_curstackinfo;
2602     dJMPENV;
2603
2604 #ifdef DEBUGGING
2605     assert(CATCH_GET == TRUE);
2606 #endif
2607     PL_op = o;
2608
2609     /* Normally, the leavetry at the end of this block of ops will
2610      * pop an op off the return stack and continue there. By setting
2611      * the op to Nullop, we force an exit from the inner runops()
2612      * loop. DAPM.
2613      */
2614     retop = pop_return();
2615     push_return(Nullop);
2616
2617 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2618  redo_body:
2619     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2620 #else
2621     JMPENV_PUSH(ret);
2622 #endif
2623     switch (ret) {
2624     case 0:
2625 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2626  redo_body:
2627         docatch_body();
2628 #endif
2629         break;
2630     case 3:
2631         /* die caught by an inner eval - continue inner loop */
2632         if (PL_restartop && cursi == PL_curstackinfo) {
2633             PL_op = PL_restartop;
2634             PL_restartop = 0;
2635             goto redo_body;
2636         }
2637         /* a die in this eval - continue in outer loop */
2638         if (!PL_restartop)
2639             break;
2640         /* FALL THROUGH */
2641     default:
2642         JMPENV_POP;
2643         PL_op = oldop;
2644         JMPENV_JUMP(ret);
2645         /* NOTREACHED */
2646     }
2647     JMPENV_POP;
2648     PL_op = oldop;
2649     return retop;
2650 }
2651
2652 OP *
2653 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2654 /* sv Text to convert to OP tree. */
2655 /* startop op_free() this to undo. */
2656 /* code Short string id of the caller. */
2657 {
2658     dSP;                                /* Make POPBLOCK work. */
2659     PERL_CONTEXT *cx;
2660     SV **newsp;
2661     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2662     I32 optype;
2663     OP dummy;
2664     OP *rop;
2665     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2666     char *tmpbuf = tbuf;
2667     char *safestr;
2668     int runtime;
2669     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2670
2671     ENTER;
2672     lex_start(sv);
2673     SAVETMPS;
2674     /* switch to eval mode */
2675
2676     if (PL_curcop == &PL_compiling) {
2677         SAVECOPSTASH_FREE(&PL_compiling);
2678         CopSTASH_set(&PL_compiling, PL_curstash);
2679     }
2680     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2681         SV *sv = sv_newmortal();
2682         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2683                        code, (unsigned long)++PL_evalseq,
2684                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2685         tmpbuf = SvPVX(sv);
2686     }
2687     else
2688         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2689     SAVECOPFILE_FREE(&PL_compiling);
2690     CopFILE_set(&PL_compiling, tmpbuf+2);
2691     SAVECOPLINE(&PL_compiling);
2692     CopLINE_set(&PL_compiling, 1);
2693     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2694        deleting the eval's FILEGV from the stash before gv_check() runs
2695        (i.e. before run-time proper). To work around the coredump that
2696        ensues, we always turn GvMULTI_on for any globals that were
2697        introduced within evals. See force_ident(). GSAR 96-10-12 */
2698     safestr = savepv(tmpbuf);
2699     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2700     SAVEHINTS();
2701 #ifdef OP_IN_REGISTER
2702     PL_opsave = op;
2703 #else
2704     SAVEVPTR(PL_op);
2705 #endif
2706     PL_hints &= HINT_UTF8;
2707
2708     /* we get here either during compilation, or via pp_regcomp at runtime */
2709     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2710     if (runtime)
2711         runcv = find_runcv(NULL);
2712
2713     PL_op = &dummy;
2714     PL_op->op_type = OP_ENTEREVAL;
2715     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2716     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2717     PUSHEVAL(cx, 0, Nullgv);
2718
2719     if (runtime)
2720         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2721     else
2722         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2723     POPBLOCK(cx,PL_curpm);
2724     POPEVAL(cx);
2725
2726     (*startop)->op_type = OP_NULL;
2727     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2728     lex_end();
2729     /* XXX DAPM do this properly one year */
2730     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2731     LEAVE;
2732     if (PL_curcop == &PL_compiling)
2733         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2734 #ifdef OP_IN_REGISTER
2735     op = PL_opsave;
2736 #endif
2737     return rop;
2738 }
2739
2740
2741 /*
2742 =for apidoc find_runcv
2743
2744 Locate the CV corresponding to the currently executing sub or eval.
2745 If db_seqp is non_null, skip CVs that are in the DB package and populate
2746 *db_seqp with the cop sequence number at the point that the DB:: code was
2747 entered. (allows debuggers to eval in the scope of the breakpoint rather
2748 than in in the scope of the debuger itself).
2749
2750 =cut
2751 */
2752
2753 CV*
2754 Perl_find_runcv(pTHX_ U32 *db_seqp)
2755 {
2756     I32          ix;
2757     PERL_SI      *si;
2758     PERL_CONTEXT *cx;
2759
2760     if (db_seqp)
2761         *db_seqp = PL_curcop->cop_seq;
2762     for (si = PL_curstackinfo; si; si = si->si_prev) {
2763         for (ix = si->si_cxix; ix >= 0; ix--) {
2764             cx = &(si->si_cxstack[ix]);
2765             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2766                 CV *cv = cx->blk_sub.cv;
2767                 /* skip DB:: code */
2768                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2769                     *db_seqp = cx->blk_oldcop->cop_seq;
2770                     continue;
2771                 }
2772                 return cv;
2773             }
2774             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2775                 return PL_compcv;
2776         }
2777     }
2778     return PL_main_cv;
2779 }
2780
2781
2782 /* Compile a require/do, an eval '', or a /(?{...})/.
2783  * In the last case, startop is non-null, and contains the address of
2784  * a pointer that should be set to the just-compiled code.
2785  * outside is the lexically enclosing CV (if any) that invoked us.
2786  */
2787
2788 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2789 STATIC OP *
2790 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2791 {
2792     dSP;
2793     OP *saveop = PL_op;
2794
2795     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2796                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2797                   : EVAL_INEVAL);
2798
2799     PUSHMARK(SP);
2800
2801     SAVESPTR(PL_compcv);
2802     PL_compcv = (CV*)NEWSV(1104,0);
2803     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2804     CvEVAL_on(PL_compcv);
2805     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2806     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2807
2808     CvOUTSIDE_SEQ(PL_compcv) = seq;
2809     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2810
2811     /* set up a scratch pad */
2812
2813     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2814
2815
2816     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2817
2818     /* make sure we compile in the right package */
2819
2820     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2821         SAVESPTR(PL_curstash);
2822         PL_curstash = CopSTASH(PL_curcop);
2823     }
2824     SAVESPTR(PL_beginav);
2825     PL_beginav = newAV();
2826     SAVEFREESV(PL_beginav);
2827     SAVEI32(PL_error_count);
2828
2829     /* try to compile it */
2830
2831     PL_eval_root = Nullop;
2832     PL_error_count = 0;
2833     PL_curcop = &PL_compiling;
2834     PL_curcop->cop_arybase = 0;
2835     if (saveop && saveop->op_flags & OPf_SPECIAL)
2836         PL_in_eval |= EVAL_KEEPERR;
2837     else
2838         sv_setpv(ERRSV,"");
2839     if (yyparse() || PL_error_count || !PL_eval_root) {
2840         SV **newsp;
2841         I32 gimme;
2842         PERL_CONTEXT *cx;
2843         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2844         STRLEN n_a;
2845
2846         PL_op = saveop;
2847         if (PL_eval_root) {
2848             op_free(PL_eval_root);
2849             PL_eval_root = Nullop;
2850         }
2851         SP = PL_stack_base + POPMARK;           /* pop original mark */
2852         if (!startop) {
2853             POPBLOCK(cx,PL_curpm);
2854             POPEVAL(cx);
2855             pop_return();
2856         }
2857         lex_end();
2858         LEAVE;
2859         if (optype == OP_REQUIRE) {
2860             char* msg = SvPVx(ERRSV, n_a);
2861             DIE(aTHX_ "%sCompilation failed in require",
2862                 *msg ? msg : "Unknown error\n");
2863         }
2864         else if (startop) {
2865             char* msg = SvPVx(ERRSV, n_a);
2866
2867             POPBLOCK(cx,PL_curpm);
2868             POPEVAL(cx);
2869             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2870                        (*msg ? msg : "Unknown error\n"));
2871         }
2872         else {
2873             char* msg = SvPVx(ERRSV, n_a);
2874             if (!*msg) {
2875                 sv_setpv(ERRSV, "Compilation error");
2876             }
2877         }
2878         RETPUSHUNDEF;
2879     }
2880     CopLINE_set(&PL_compiling, 0);
2881     if (startop) {
2882         *startop = PL_eval_root;
2883     } else
2884         SAVEFREEOP(PL_eval_root);
2885     if (gimme & G_VOID)
2886         scalarvoid(PL_eval_root);
2887     else if (gimme & G_ARRAY)
2888         list(PL_eval_root);
2889     else
2890         scalar(PL_eval_root);
2891
2892     DEBUG_x(dump_eval());
2893
2894     /* Register with debugger: */
2895     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2896         CV *cv = get_cv("DB::postponed", FALSE);
2897         if (cv) {
2898             dSP;
2899             PUSHMARK(SP);
2900             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2901             PUTBACK;
2902             call_sv((SV*)cv, G_DISCARD);
2903         }
2904     }
2905
2906     /* compiled okay, so do it */
2907
2908     CvDEPTH(PL_compcv) = 1;
2909     SP = PL_stack_base + POPMARK;               /* pop original mark */
2910     PL_op = saveop;                     /* The caller may need it. */
2911     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2912
2913     RETURNOP(PL_eval_start);
2914 }
2915
2916 STATIC PerlIO *
2917 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2918 {
2919     STRLEN namelen = strlen(name);
2920     PerlIO *fp;
2921
2922     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2923         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2924         char *pmc = SvPV_nolen(pmcsv);
2925         Stat_t pmstat;
2926         Stat_t pmcstat;
2927         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2928             fp = PerlIO_open(name, mode);
2929         }
2930         else {
2931             if (PerlLIO_stat(name, &pmstat) < 0 ||
2932                 pmstat.st_mtime < pmcstat.st_mtime)
2933             {
2934                 fp = PerlIO_open(pmc, mode);
2935             }
2936             else {
2937                 fp = PerlIO_open(name, mode);
2938             }
2939         }
2940         SvREFCNT_dec(pmcsv);
2941     }
2942     else {
2943         fp = PerlIO_open(name, mode);
2944     }
2945     return fp;
2946 }
2947
2948 PP(pp_require)
2949 {
2950     dSP;
2951     register PERL_CONTEXT *cx;
2952     SV *sv;
2953     char *name;
2954     STRLEN len;
2955     char *tryname = Nullch;
2956     SV *namesv = Nullsv;
2957     SV** svp;
2958     I32 gimme = GIMME_V;
2959     PerlIO *tryrsfp = 0;
2960     STRLEN n_a;
2961     int filter_has_file = 0;
2962     GV *filter_child_proc = 0;
2963     SV *filter_state = 0;
2964     SV *filter_sub = 0;
2965     SV *hook_sv = 0;
2966     SV *encoding;
2967     OP *op;
2968
2969     sv = POPs;
2970     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2971         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2972             UV rev = 0, ver = 0, sver = 0;
2973             STRLEN len;
2974             U8 *s = (U8*)SvPVX(sv);
2975             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2976             if (s < end) {
2977                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2978                 s += len;
2979                 if (s < end) {
2980                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2981                     s += len;
2982                     if (s < end)
2983                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2984                 }
2985             }
2986             if (PERL_REVISION < rev
2987                 || (PERL_REVISION == rev
2988                     && (PERL_VERSION < ver
2989                         || (PERL_VERSION == ver
2990                             && PERL_SUBVERSION < sver))))
2991             {
2992                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2993                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2994                     PERL_VERSION, PERL_SUBVERSION);
2995             }
2996             if (ckWARN(WARN_PORTABLE))
2997                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2998                         "v-string in use/require non-portable");
2999             RETPUSHYES;
3000         }
3001         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3002             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3003                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3004                 + 0.00000099 < SvNV(sv))
3005             {
3006                 NV nrev = SvNV(sv);
3007                 UV rev = (UV)nrev;
3008                 NV nver = (nrev - rev) * 1000;
3009                 UV ver = (UV)(nver + 0.0009);
3010                 NV nsver = (nver - ver) * 1000;
3011                 UV sver = (UV)(nsver + 0.0009);
3012
3013                 /* help out with the "use 5.6" confusion */
3014                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3015                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3016                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3017                         "this is only v%d.%d.%d, stopped",
3018                         rev, ver, sver, rev, ver/100,
3019                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3020                 }
3021                 else {
3022                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3023                         "this is only v%d.%d.%d, stopped",
3024                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3025                         PERL_SUBVERSION);
3026                 }
3027             }
3028             RETPUSHYES;
3029         }
3030     }
3031     name = SvPV(sv, len);
3032     if (!(name && len > 0 && *name))
3033         DIE(aTHX_ "Null filename used");
3034     TAINT_PROPER("require");
3035     if (PL_op->op_type == OP_REQUIRE &&
3036       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3037       *svp != &PL_sv_undef)
3038         RETPUSHYES;
3039
3040     /* prepare to compile file */
3041
3042     if (path_is_absolute(name)) {
3043         tryname = name;
3044         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3045     }
3046 #ifdef MACOS_TRADITIONAL
3047     if (!tryrsfp) {
3048         char newname[256];
3049
3050         MacPerl_CanonDir(name, newname, 1);
3051         if (path_is_absolute(newname)) {
3052             tryname = newname;
3053             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3054         }
3055     }
3056 #endif
3057     if (!tryrsfp) {
3058         AV *ar = GvAVn(PL_incgv);
3059         I32 i;
3060 #ifdef VMS
3061         char *unixname;
3062         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3063 #endif
3064         {
3065             namesv = NEWSV(806, 0);
3066             for (i = 0; i <= AvFILL(ar); i++) {
3067                 SV *dirsv = *av_fetch(ar, i, TRUE);
3068
3069                 if (SvROK(dirsv)) {
3070                     int count;
3071                     SV *loader = dirsv;
3072
3073                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3074                         && !sv_isobject(loader))
3075                     {
3076                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3077                     }
3078
3079                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3080                                    PTR2UV(SvRV(dirsv)), name);
3081                     tryname = SvPVX(namesv);
3082                     tryrsfp = 0;
3083
3084                     ENTER;
3085                     SAVETMPS;
3086                     EXTEND(SP, 2);
3087
3088                     PUSHMARK(SP);
3089                     PUSHs(dirsv);
3090                     PUSHs(sv);
3091                     PUTBACK;
3092                     if (sv_isobject(loader))
3093                         count = call_method("INC", G_ARRAY);
3094                     else
3095                         count = call_sv(loader, G_ARRAY);
3096                     SPAGAIN;
3097
3098                     if (count > 0) {
3099                         int i = 0;
3100                         SV *arg;
3101
3102                         SP -= count - 1;
3103                         arg = SP[i++];
3104
3105                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3106                             arg = SvRV(arg);
3107                         }
3108
3109                         if (SvTYPE(arg) == SVt_PVGV) {
3110                             IO *io = GvIO((GV *)arg);
3111
3112                             ++filter_has_file;
3113
3114                             if (io) {
3115                                 tryrsfp = IoIFP(io);
3116                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3117                                     /* reading from a child process doesn't
3118                                        nest -- when returning from reading
3119                                        the inner module, the outer one is
3120                                        unreadable (closed?)  I've tried to
3121                                        save the gv to manage the lifespan of
3122                                        the pipe, but this didn't help. XXX */
3123                                     filter_child_proc = (GV *)arg;
3124                                     (void)SvREFCNT_inc(filter_child_proc);
3125                                 }
3126                                 else {
3127                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3128                                         PerlIO_close(IoOFP(io));
3129                                     }
3130                                     IoIFP(io) = Nullfp;
3131                                     IoOFP(io) = Nullfp;
3132                                 }
3133                             }
3134
3135                             if (i < count) {
3136                                 arg = SP[i++];
3137                             }
3138                         }
3139
3140                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3141                             filter_sub = arg;
3142                             (void)SvREFCNT_inc(filter_sub);
3143
3144                             if (i < count) {
3145                                 filter_state = SP[i];
3146                                 (void)SvREFCNT_inc(filter_state);
3147                             }
3148
3149                             if (tryrsfp == 0) {
3150                                 tryrsfp = PerlIO_open("/dev/null",
3151                                                       PERL_SCRIPT_MODE);
3152                             }
3153                         }
3154                     }
3155
3156                     PUTBACK;
3157                     FREETMPS;
3158                     LEAVE;
3159
3160                     if (tryrsfp) {
3161                         hook_sv = dirsv;
3162                         break;
3163                     }
3164
3165                     filter_has_file = 0;
3166                     if (filter_child_proc) {
3167                         SvREFCNT_dec(filter_child_proc);
3168                         filter_child_proc = 0;
3169                     }
3170                     if (filter_state) {
3171                         SvREFCNT_dec(filter_state);
3172                         filter_state = 0;
3173                     }
3174                     if (filter_sub) {
3175                         SvREFCNT_dec(filter_sub);
3176                         filter_sub = 0;
3177                     }
3178                 }
3179                 else {
3180                   if (!path_is_absolute(name)
3181 #ifdef MACOS_TRADITIONAL
3182                         /* We consider paths of the form :a:b ambiguous and interpret them first
3183                            as global then as local
3184                         */
3185                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3186 #endif
3187                   ) {
3188                     char *dir = SvPVx(dirsv, n_a);
3189 #ifdef MACOS_TRADITIONAL
3190                     char buf1[256];
3191                     char buf2[256];
3192
3193                     MacPerl_CanonDir(name, buf2, 1);
3194                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3195 #else
3196 #ifdef VMS
3197                     char *unixdir;
3198                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3199                         continue;
3200                     sv_setpv(namesv, unixdir);
3201                     sv_catpv(namesv, unixname);
3202 #else
3203                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3204 #endif
3205 #endif
3206                     TAINT_PROPER("require");
3207                     tryname = SvPVX(namesv);
3208                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3209                     if (tryrsfp) {
3210                         if (tryname[0] == '.' && tryname[1] == '/')
3211                             tryname += 2;
3212                         break;
3213                     }
3214                   }
3215                 }
3216             }
3217         }
3218     }
3219     SAVECOPFILE_FREE(&PL_compiling);
3220     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3221     SvREFCNT_dec(namesv);
3222     if (!tryrsfp) {
3223         if (PL_op->op_type == OP_REQUIRE) {
3224             char *msgstr = name;
3225             if (namesv) {                       /* did we lookup @INC? */
3226                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3227                 SV *dirmsgsv = NEWSV(0, 0);
3228                 AV *ar = GvAVn(PL_incgv);
3229                 I32 i;
3230                 sv_catpvn(msg, " in @INC", 8);
3231                 if (instr(SvPVX(msg), ".h "))
3232                     sv_catpv(msg, " (change .h to .ph maybe?)");
3233                 if (instr(SvPVX(msg), ".ph "))
3234                     sv_catpv(msg, " (did you run h2ph?)");
3235                 sv_catpv(msg, " (@INC contains:");
3236                 for (i = 0; i <= AvFILL(ar); i++) {
3237                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3238                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3239                     sv_catsv(msg, dirmsgsv);
3240                 }
3241                 sv_catpvn(msg, ")", 1);
3242                 SvREFCNT_dec(dirmsgsv);
3243                 msgstr = SvPV_nolen(msg);
3244             }
3245             DIE(aTHX_ "Can't locate %s", msgstr);
3246         }
3247
3248         RETPUSHUNDEF;
3249     }
3250     else
3251         SETERRNO(0, SS_NORMAL);
3252
3253     /* Assume success here to prevent recursive requirement. */
3254     len = strlen(name);
3255     /* Check whether a hook in @INC has already filled %INC */
3256     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3257         (void)hv_store(GvHVn(PL_incgv), name, len,
3258                        (hook_sv ? SvREFCNT_inc(hook_sv)
3259                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3260                        0 );
3261     }
3262
3263     ENTER;
3264     SAVETMPS;
3265     lex_start(sv_2mortal(newSVpvn("",0)));
3266     SAVEGENERICSV(PL_rsfp_filters);
3267     PL_rsfp_filters = Nullav;
3268
3269     PL_rsfp = tryrsfp;
3270     SAVEHINTS();
3271     PL_hints = 0;
3272     SAVESPTR(PL_compiling.cop_warnings);
3273     if (PL_dowarn & G_WARN_ALL_ON)
3274         PL_compiling.cop_warnings = pWARN_ALL ;
3275     else if (PL_dowarn & G_WARN_ALL_OFF)
3276         PL_compiling.cop_warnings = pWARN_NONE ;
3277     else if (PL_taint_warn)
3278         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3279     else
3280         PL_compiling.cop_warnings = pWARN_STD ;
3281     SAVESPTR(PL_compiling.cop_io);
3282     PL_compiling.cop_io = Nullsv;
3283
3284     if (filter_sub || filter_child_proc) {
3285         SV *datasv = filter_add(run_user_filter, Nullsv);
3286         IoLINES(datasv) = filter_has_file;
3287         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3288         IoTOP_GV(datasv) = (GV *)filter_state;
3289         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3290     }
3291
3292     /* switch to eval mode */
3293     push_return(PL_op->op_next);
3294     PUSHBLOCK(cx, CXt_EVAL, SP);
3295     PUSHEVAL(cx, name, Nullgv);
3296
3297     SAVECOPLINE(&PL_compiling);
3298     CopLINE_set(&PL_compiling, 0);
3299
3300     PUTBACK;
3301
3302     /* Store and reset encoding. */
3303     encoding = PL_encoding;
3304     PL_encoding = Nullsv;
3305
3306     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3307
3308     /* Restore encoding. */
3309     PL_encoding = encoding;
3310
3311     return op;
3312 }
3313
3314 PP(pp_dofile)
3315 {
3316     return pp_require();
3317 }
3318
3319 PP(pp_entereval)
3320 {
3321     dSP;
3322     register PERL_CONTEXT *cx;
3323     dPOPss;
3324     I32 gimme = GIMME_V, was = PL_sub_generation;
3325     char tbuf[TYPE_DIGITS(long) + 12];
3326     char *tmpbuf = tbuf;
3327     char *safestr;
3328     STRLEN len;
3329     OP *ret;
3330     CV* runcv;
3331     U32 seq;
3332
3333     if (!SvPV(sv,len))
3334         RETPUSHUNDEF;
3335     TAINT_PROPER("eval");
3336
3337     ENTER;
3338     lex_start(sv);
3339     SAVETMPS;
3340
3341     /* switch to eval mode */
3342
3343     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3344         SV *sv = sv_newmortal();
3345         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3346                        (unsigned long)++PL_evalseq,
3347                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3348         tmpbuf = SvPVX(sv);
3349     }
3350     else
3351         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3352     SAVECOPFILE_FREE(&PL_compiling);
3353     CopFILE_set(&PL_compiling, tmpbuf+2);
3354     SAVECOPLINE(&PL_compiling);
3355     CopLINE_set(&PL_compiling, 1);
3356     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3357        deleting the eval's FILEGV from the stash before gv_check() runs
3358        (i.e. before run-time proper). To work around the coredump that
3359        ensues, we always turn GvMULTI_on for any globals that were
3360        introduced within evals. See force_ident(). GSAR 96-10-12 */
3361     safestr = savepv(tmpbuf);
3362     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3363     SAVEHINTS();
3364     PL_hints = PL_op->op_targ;
3365     SAVESPTR(PL_compiling.cop_warnings);
3366     if (specialWARN(PL_curcop->cop_warnings))
3367         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3368     else {
3369         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3370         SAVEFREESV(PL_compiling.cop_warnings);
3371     }
3372     SAVESPTR(PL_compiling.cop_io);
3373     if (specialCopIO(PL_curcop->cop_io))
3374         PL_compiling.cop_io = PL_curcop->cop_io;
3375     else {
3376         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3377         SAVEFREESV(PL_compiling.cop_io);
3378     }
3379     /* special case: an eval '' executed within the DB package gets lexically
3380      * placed in the first non-DB CV rather than the current CV - this
3381      * allows the debugger to execute code, find lexicals etc, in the
3382      * scope of the code being debugged. Passing &seq gets find_runcv
3383      * to do the dirty work for us */
3384     runcv = find_runcv(&seq);
3385
3386     push_return(PL_op->op_next);
3387     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3388     PUSHEVAL(cx, 0, Nullgv);
3389
3390     /* prepare to compile string */
3391
3392     if (PERLDB_LINE && PL_curstash != PL_debstash)
3393         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3394     PUTBACK;
3395     ret = doeval(gimme, NULL, runcv, seq);
3396     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3397         && ret != PL_op->op_next) {     /* Successive compilation. */
3398         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3399     }
3400     return DOCATCH(ret);
3401 }
3402
3403 PP(pp_leaveeval)
3404 {
3405     dSP;
3406     register SV **mark;
3407     SV **newsp;
3408     PMOP *newpm;
3409     I32 gimme;
3410     register PERL_CONTEXT *cx;
3411     OP *retop;
3412     U8 save_flags = PL_op -> op_flags;
3413     I32 optype;
3414
3415     POPBLOCK(cx,newpm);
3416     POPEVAL(cx);
3417     retop = pop_return();
3418
3419     TAINT_NOT;
3420     if (gimme == G_VOID)
3421         MARK = newsp;
3422     else if (gimme == G_SCALAR) {
3423         MARK = newsp + 1;
3424         if (MARK <= SP) {
3425             if (SvFLAGS(TOPs) & SVs_TEMP)
3426                 *MARK = TOPs;
3427             else
3428                 *MARK = sv_mortalcopy(TOPs);
3429         }
3430         else {
3431             MEXTEND(mark,0);
3432             *MARK = &PL_sv_undef;
3433         }
3434         SP = MARK;
3435     }
3436     else {
3437         /* in case LEAVE wipes old return values */
3438         for (mark = newsp + 1; mark <= SP; mark++) {
3439             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3440                 *mark = sv_mortalcopy(*mark);
3441                 TAINT_NOT;      /* Each item is independent */
3442             }
3443         }
3444     }
3445     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3446
3447 #ifdef DEBUGGING
3448     assert(CvDEPTH(PL_compcv) == 1);
3449 #endif
3450     CvDEPTH(PL_compcv) = 0;
3451     lex_end();
3452
3453     if (optype == OP_REQUIRE &&
3454         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3455     {
3456         /* Unassume the success we assumed earlier. */
3457         SV *nsv = cx->blk_eval.old_namesv;
3458         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3459         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3460         /* die_where() did LEAVE, or we won't be here */
3461     }
3462     else {
3463         LEAVE;
3464         if (!(save_flags & OPf_SPECIAL))
3465             sv_setpv(ERRSV,"");
3466     }
3467
3468     RETURNOP(retop);
3469 }
3470
3471 PP(pp_entertry)
3472 {
3473     dSP;
3474     register PERL_CONTEXT *cx;
3475     I32 gimme = GIMME_V;
3476
3477     ENTER;
3478     SAVETMPS;
3479
3480     push_return(cLOGOP->op_other->op_next);
3481     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3482     PUSHEVAL(cx, 0, 0);
3483
3484     PL_in_eval = EVAL_INEVAL;
3485     sv_setpv(ERRSV,"");
3486     PUTBACK;
3487     return DOCATCH(PL_op->op_next);
3488 }
3489
3490 PP(pp_leavetry)
3491 {
3492     dSP;
3493     register SV **mark;
3494     SV **newsp;
3495     PMOP *newpm;
3496     OP* retop;
3497     I32 gimme;
3498     register PERL_CONTEXT *cx;
3499     I32 optype;
3500
3501     POPBLOCK(cx,newpm);
3502     POPEVAL(cx);
3503     retop = pop_return();
3504
3505     TAINT_NOT;
3506     if (gimme == G_VOID)
3507         SP = newsp;
3508     else if (gimme == G_SCALAR) {
3509         MARK = newsp + 1;
3510         if (MARK <= SP) {
3511             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3512                 *MARK = TOPs;
3513             else
3514                 *MARK = sv_mortalcopy(TOPs);
3515         }
3516         else {
3517             MEXTEND(mark,0);
3518             *MARK = &PL_sv_undef;
3519         }
3520         SP = MARK;
3521     }
3522     else {
3523         /* in case LEAVE wipes old return values */
3524         for (mark = newsp + 1; mark <= SP; mark++) {
3525             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3526                 *mark = sv_mortalcopy(*mark);
3527                 TAINT_NOT;      /* Each item is independent */
3528             }
3529         }
3530     }
3531     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3532
3533     LEAVE;
3534     sv_setpv(ERRSV,"");
3535     RETURNOP(retop);
3536 }
3537
3538 STATIC void
3539 S_doparseform(pTHX_ SV *sv)
3540 {
3541     STRLEN len;
3542     register char *s = SvPV_force(sv, len);
3543     register char *send = s + len;
3544     register char *base = Nullch;
3545     register I32 skipspaces = 0;
3546     bool noblank   = FALSE;
3547     bool repeat    = FALSE;
3548     bool postspace = FALSE;
3549     U16 *fops;
3550     register U16 *fpc;
3551     U16 *linepc = 0;
3552     register I32 arg;
3553     bool ischop;
3554
3555     if (len == 0)
3556         Perl_croak(aTHX_ "Null picture in formline");
3557
3558     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3559     fpc = fops;
3560
3561     if (s < send) {
3562         linepc = fpc;
3563         *fpc++ = FF_LINEMARK;
3564         noblank = repeat = FALSE;
3565         base = s;
3566     }
3567
3568     while (s <= send) {
3569         switch (*s++) {
3570         default:
3571             skipspaces = 0;
3572             continue;
3573
3574         case '~':
3575             if (*s == '~') {
3576                 repeat = TRUE;
3577                 *s = ' ';
3578             }
3579             noblank = TRUE;
3580             s[-1] = ' ';
3581             /* FALL THROUGH */
3582         case ' ': case '\t':
3583             skipspaces++;
3584             continue;
3585
3586         case '\n': case 0:
3587             arg = s - base;
3588             skipspaces++;
3589             arg -= skipspaces;
3590             if (arg) {
3591                 if (postspace)
3592                     *fpc++ = FF_SPACE;
3593                 *fpc++ = FF_LITERAL;
3594                 *fpc++ = (U16)arg;
3595             }
3596             postspace = FALSE;
3597             if (s <= send)
3598                 skipspaces--;
3599             if (skipspaces) {
3600                 *fpc++ = FF_SKIP;
3601                 *fpc++ = (U16)skipspaces;
3602             }
3603             skipspaces = 0;
3604             if (s <= send)
3605                 *fpc++ = FF_NEWLINE;
3606             if (noblank) {
3607                 *fpc++ = FF_BLANK;
3608                 if (repeat)
3609                     arg = fpc - linepc + 1;
3610                 else
3611                     arg = 0;
3612                 *fpc++ = (U16)arg;
3613             }
3614             if (s < send) {
3615                 linepc = fpc;
3616                 *fpc++ = FF_LINEMARK;
3617                 noblank = repeat = FALSE;
3618                 base = s;
3619             }
3620             else
3621                 s++;
3622             continue;
3623
3624         case '@':
3625         case '^':
3626             ischop = s[-1] == '^';
3627
3628             if (postspace) {
3629                 *fpc++ = FF_SPACE;
3630                 postspace = FALSE;
3631             }
3632             arg = (s - base) - 1;
3633             if (arg) {
3634                 *fpc++ = FF_LITERAL;
3635                 *fpc++ = (U16)arg;
3636             }
3637
3638             base = s - 1;
3639             *fpc++ = FF_FETCH;
3640             if (*s == '*') {
3641                 s++;
3642                 *fpc++ = 0;
3643                 *fpc++ = FF_LINEGLOB;
3644             }
3645             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3646                 arg = ischop ? 512 : 0;
3647                 base = s - 1;
3648                 while (*s == '#')
3649                     s++;
3650                 if (*s == '.') {
3651                     char *f;
3652                     s++;
3653                     f = s;
3654                     while (*s == '#')
3655                         s++;
3656                     arg |= 256 + (s - f);
3657                 }
3658                 *fpc++ = s - base;              /* fieldsize for FETCH */
3659                 *fpc++ = FF_DECIMAL;
3660                 *fpc++ = (U16)arg;
3661             }
3662             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3663                 arg = ischop ? 512 : 0;
3664                 base = s - 1;
3665                 s++;                                /* skip the '0' first */
3666                 while (*s == '#')
3667                     s++;
3668                 if (*s == '.') {
3669                     char *f;
3670                     s++;
3671                     f = s;
3672                     while (*s == '#')
3673                         s++;
3674                     arg |= 256 + (s - f);
3675                 }
3676                 *fpc++ = s - base;                /* fieldsize for FETCH */
3677                 *fpc++ = FF_0DECIMAL;
3678                 *fpc++ = (U16)arg;
3679             }
3680             else {
3681                 I32 prespace = 0;
3682                 bool ismore = FALSE;
3683
3684                 if (*s == '>') {
3685                     while (*++s == '>') ;
3686                     prespace = FF_SPACE;
3687                 }
3688                 else if (*s == '|') {
3689                     while (*++s == '|') ;
3690                     prespace = FF_HALFSPACE;
3691                     postspace = TRUE;
3692                 }
3693                 else {
3694                     if (*s == '<')
3695                         while (*++s == '<') ;
3696                     postspace = TRUE;
3697                 }
3698                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3699                     s += 3;
3700                     ismore = TRUE;
3701                 }
3702                 *fpc++ = s - base;              /* fieldsize for FETCH */
3703
3704                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3705
3706                 if (prespace)
3707                     *fpc++ = (U16)prespace;
3708                 *fpc++ = FF_ITEM;
3709                 if (ismore)
3710                     *fpc++ = FF_MORE;
3711                 if (ischop)
3712                     *fpc++ = FF_CHOP;
3713             }
3714             base = s;
3715             skipspaces = 0;
3716             continue;
3717         }
3718     }
3719     *fpc++ = FF_END;
3720
3721     arg = fpc - fops;
3722     { /* need to jump to the next word */
3723         int z;
3724         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3725         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3726         s = SvPVX(sv) + SvCUR(sv) + z;
3727     }
3728     Copy(fops, s, arg, U16);
3729     Safefree(fops);
3730     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3731     SvCOMPILED_on(sv);
3732 }
3733
3734 static I32
3735 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3736 {
3737     SV *datasv = FILTER_DATA(idx);
3738     int filter_has_file = IoLINES(datasv);
3739     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3740     SV *filter_state = (SV *)IoTOP_GV(datasv);
3741     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3742     int len = 0;
3743
3744     /* I was having segfault trouble under Linux 2.2.5 after a
3745        parse error occured.  (Had to hack around it with a test
3746        for PL_error_count == 0.)  Solaris doesn't segfault --
3747        not sure where the trouble is yet.  XXX */
3748
3749     if (filter_has_file) {
3750         len = FILTER_READ(idx+1, buf_sv, maxlen);
3751     }
3752
3753     if (filter_sub && len >= 0) {
3754         dSP;
3755         int count;
3756
3757         ENTER;
3758         SAVE_DEFSV;
3759         SAVETMPS;
3760         EXTEND(SP, 2);
3761
3762         DEFSV = buf_sv;
3763         PUSHMARK(SP);
3764         PUSHs(sv_2mortal(newSViv(maxlen)));
3765         if (filter_state) {
3766             PUSHs(filter_state);
3767         }
3768         PUTBACK;
3769         count = call_sv(filter_sub, G_SCALAR);
3770         SPAGAIN;
3771
3772         if (count > 0) {
3773             SV *out = POPs;
3774             if (SvOK(out)) {
3775                 len = SvIV(out);
3776             }
3777         }
3778
3779         PUTBACK;
3780         FREETMPS;
3781         LEAVE;
3782     }
3783
3784     if (len <= 0) {
3785         IoLINES(datasv) = 0;
3786         if (filter_child_proc) {
3787             SvREFCNT_dec(filter_child_proc);
3788             IoFMT_GV(datasv) = Nullgv;
3789         }
3790         if (filter_state) {
3791             SvREFCNT_dec(filter_state);
3792             IoTOP_GV(datasv) = Nullgv;
3793         }
3794         if (filter_sub) {
3795             SvREFCNT_dec(filter_sub);
3796             IoBOTTOM_GV(datasv) = Nullgv;
3797         }
3798         filter_del(run_user_filter);
3799     }
3800
3801     return len;
3802 }
3803
3804 /* perhaps someone can come up with a better name for
3805    this?  it is not really "absolute", per se ... */
3806 static bool
3807 S_path_is_absolute(pTHX_ char *name)
3808 {
3809     if (PERL_FILE_IS_ABSOLUTE(name)
3810 #ifdef MACOS_TRADITIONAL
3811         || (*name == ':'))
3812 #else
3813         || (*name == '.' && (name[1] == '/' ||
3814                              (name[1] == '.' && name[2] == '/'))))
3815 #endif
3816     {
3817         return TRUE;
3818     }
3819     else
3820         return FALSE;
3821 }