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     LEAVE;
1953     /* Stack values are safe: */
1954     if (popsub2) {
1955         POPSUB(cx,sv);  /* release CV and @_ ... */
1956     }
1957     else
1958         sv = Nullsv;
1959     PL_curpm = newpm;   /* ... and pop $1 et al */
1960
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     LEAVE;
2037     /* Stack values are safe: */
2038     switch (pop2) {
2039     case CXt_LOOP:
2040         POPLOOP(cx);    /* release loop vars ... */
2041         LEAVE;
2042         break;
2043     case CXt_SUB:
2044         POPSUB(cx,sv);  /* release CV and @_ ... */
2045         break;
2046     }
2047     PL_curpm = newpm;   /* ... and pop $1 et al */
2048
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             SvREFCNT_inc(cv); /* avoid premature free during unwind */
2207             FREETMPS;
2208             cxix = dopoptosub(cxstack_ix);
2209             if (cxix < 0)
2210                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2211             if (cxix < cxstack_ix)
2212                 dounwind(cxix);
2213             TOPBLOCK(cx);
2214             if (CxREALEVAL(cx))
2215                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2216             mark = PL_stack_sp;
2217             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2218                 /* put @_ back onto stack */
2219                 AV* av = cx->blk_sub.argarray;
2220
2221                 items = AvFILLp(av) + 1;
2222                 PL_stack_sp++;
2223                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2224                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2225                 PL_stack_sp += items;
2226                 SvREFCNT_dec(GvAV(PL_defgv));
2227                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2228                 /* abandon @_ if it got reified */
2229                 if (AvREAL(av)) {
2230                     (void)sv_2mortal((SV*)av);  /* delay until return */
2231                     av = newAV();
2232                     av_extend(av, items-1);
2233                     AvFLAGS(av) = AVf_REIFY;
2234                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2235                 }
2236             }
2237             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2238                 AV* av;
2239                 av = GvAV(PL_defgv);
2240                 items = AvFILLp(av) + 1;
2241                 PL_stack_sp++;
2242                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2243                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2244                 PL_stack_sp += items;
2245             }
2246             if (CxTYPE(cx) == CXt_SUB &&
2247                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2248                 SvREFCNT_dec(cx->blk_sub.cv);
2249             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2250             LEAVE_SCOPE(oldsave);
2251
2252             /* Now do some callish stuff. */
2253             SAVETMPS;
2254             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2255             if (CvXSUB(cv)) {
2256 #ifdef PERL_XSUB_OLDSTYLE
2257                 if (CvOLDSTYLE(cv)) {
2258                     I32 (*fp3)(int,int,int);
2259                     while (SP > mark) {
2260                         SP[1] = SP[0];
2261                         SP--;
2262                     }
2263                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2264                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2265                                    mark - PL_stack_base + 1,
2266                                    items);
2267                     SP = PL_stack_base + items;
2268                 }
2269                 else
2270 #endif /* PERL_XSUB_OLDSTYLE */
2271                 {
2272                     SV **newsp;
2273                     I32 gimme;
2274
2275                     PL_stack_sp--;              /* There is no cv arg. */
2276                     /* Push a mark for the start of arglist */
2277                     PUSHMARK(mark);
2278                     (void)(*CvXSUB(cv))(aTHX_ cv);
2279                     /* Pop the current context like a decent sub should */
2280                     POPBLOCK(cx, PL_curpm);
2281                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2282                 }
2283                 LEAVE;
2284                 return pop_return();
2285             }
2286             else {
2287                 AV* padlist = CvPADLIST(cv);
2288                 if (CxTYPE(cx) == CXt_EVAL) {
2289                     PL_in_eval = cx->blk_eval.old_in_eval;
2290                     PL_eval_root = cx->blk_eval.old_eval_root;
2291                     cx->cx_type = CXt_SUB;
2292                     cx->blk_sub.hasargs = 0;
2293                 }
2294                 cx->blk_sub.cv = cv;
2295                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2296
2297                 CvDEPTH(cv)++;
2298                 if (CvDEPTH(cv) < 2)
2299                     (void)SvREFCNT_inc(cv);
2300                 else {
2301                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2302                         sub_crush_depth(cv);
2303                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2304                 }
2305                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2306                 if (cx->blk_sub.hasargs)
2307                 {
2308                     AV* av = (AV*)PAD_SVl(0);
2309                     SV** ary;
2310
2311                     cx->blk_sub.savearray = GvAV(PL_defgv);
2312                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2313                     CX_CURPAD_SAVE(cx->blk_sub);
2314                     cx->blk_sub.argarray = av;
2315                     ++mark;
2316
2317                     if (items >= AvMAX(av) + 1) {
2318                         ary = AvALLOC(av);
2319                         if (AvARRAY(av) != ary) {
2320                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2321                             SvPVX(av) = (char*)ary;
2322                         }
2323                         if (items >= AvMAX(av) + 1) {
2324                             AvMAX(av) = items - 1;
2325                             Renew(ary,items+1,SV*);
2326                             AvALLOC(av) = ary;
2327                             SvPVX(av) = (char*)ary;
2328                         }
2329                     }
2330                     Copy(mark,AvARRAY(av),items,SV*);
2331                     AvFILLp(av) = items - 1;
2332                     assert(!AvREAL(av));
2333                     while (items--) {
2334                         if (*mark)
2335                             SvTEMP_off(*mark);
2336                         mark++;
2337                     }
2338                 }
2339                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2340                     /*
2341                      * We do not care about using sv to call CV;
2342                      * it's for informational purposes only.
2343                      */
2344                     SV *sv = GvSV(PL_DBsub);
2345                     CV *gotocv;
2346
2347                     if (PERLDB_SUB_NN) {
2348                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2349                     } else {
2350                         save_item(sv);
2351                         gv_efullname3(sv, CvGV(cv), Nullch);
2352                     }
2353                     if (  PERLDB_GOTO
2354                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2355                         PUSHMARK( PL_stack_sp );
2356                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2357                         PL_stack_sp--;
2358                     }
2359                 }
2360                 RETURNOP(CvSTART(cv));
2361             }
2362         }
2363         else {
2364             label = SvPV(sv,n_a);
2365             if (!(do_dump || *label))
2366                 DIE(aTHX_ must_have_label);
2367         }
2368     }
2369     else if (PL_op->op_flags & OPf_SPECIAL) {
2370         if (! do_dump)
2371             DIE(aTHX_ must_have_label);
2372     }
2373     else
2374         label = cPVOP->op_pv;
2375
2376     if (label && *label) {
2377         OP *gotoprobe = 0;
2378         bool leaving_eval = FALSE;
2379         bool in_block = FALSE;
2380         PERL_CONTEXT *last_eval_cx = 0;
2381
2382         /* find label */
2383
2384         PL_lastgotoprobe = 0;
2385         *enterops = 0;
2386         for (ix = cxstack_ix; ix >= 0; ix--) {
2387             cx = &cxstack[ix];
2388             switch (CxTYPE(cx)) {
2389             case CXt_EVAL:
2390                 leaving_eval = TRUE;
2391                 if (CxREALEVAL(cx)) {
2392                     gotoprobe = (last_eval_cx ?
2393                                 last_eval_cx->blk_eval.old_eval_root :
2394                                 PL_eval_root);
2395                     last_eval_cx = cx;
2396                     break;
2397                 }
2398                 /* else fall through */
2399             case CXt_LOOP:
2400                 gotoprobe = cx->blk_oldcop->op_sibling;
2401                 break;
2402             case CXt_SUBST:
2403                 continue;
2404             case CXt_BLOCK:
2405                 if (ix) {
2406                     gotoprobe = cx->blk_oldcop->op_sibling;
2407                     in_block = TRUE;
2408                 } else
2409                     gotoprobe = PL_main_root;
2410                 break;
2411             case CXt_SUB:
2412                 if (CvDEPTH(cx->blk_sub.cv)) {
2413                     gotoprobe = CvROOT(cx->blk_sub.cv);
2414                     break;
2415                 }
2416                 /* FALL THROUGH */
2417             case CXt_FORMAT:
2418             case CXt_NULL:
2419                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2420             default:
2421                 if (ix)
2422                     DIE(aTHX_ "panic: goto");
2423                 gotoprobe = PL_main_root;
2424                 break;
2425             }
2426             if (gotoprobe) {
2427                 retop = dofindlabel(gotoprobe, label,
2428                                     enterops, enterops + GOTO_DEPTH);
2429                 if (retop)
2430                     break;
2431             }
2432             PL_lastgotoprobe = gotoprobe;
2433         }
2434         if (!retop)
2435             DIE(aTHX_ "Can't find label %s", label);
2436
2437         /* if we're leaving an eval, check before we pop any frames
2438            that we're not going to punt, otherwise the error
2439            won't be caught */
2440
2441         if (leaving_eval && *enterops && enterops[1]) {
2442             I32 i;
2443             for (i = 1; enterops[i]; i++)
2444                 if (enterops[i]->op_type == OP_ENTERITER)
2445                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2446         }
2447
2448         /* pop unwanted frames */
2449
2450         if (ix < cxstack_ix) {
2451             I32 oldsave;
2452
2453             if (ix < 0)
2454                 ix = 0;
2455             dounwind(ix);
2456             TOPBLOCK(cx);
2457             oldsave = PL_scopestack[PL_scopestack_ix];
2458             LEAVE_SCOPE(oldsave);
2459         }
2460
2461         /* push wanted frames */
2462
2463         if (*enterops && enterops[1]) {
2464             OP *oldop = PL_op;
2465             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2466             for (; enterops[ix]; ix++) {
2467                 PL_op = enterops[ix];
2468                 /* Eventually we may want to stack the needed arguments
2469                  * for each op.  For now, we punt on the hard ones. */
2470                 if (PL_op->op_type == OP_ENTERITER)
2471                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2472                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2473             }
2474             PL_op = oldop;
2475         }
2476     }
2477
2478     if (do_dump) {
2479 #ifdef VMS
2480         if (!retop) retop = PL_main_start;
2481 #endif
2482         PL_restartop = retop;
2483         PL_do_undump = TRUE;
2484
2485         my_unexec();
2486
2487         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2488         PL_do_undump = FALSE;
2489     }
2490
2491     RETURNOP(retop);
2492 }
2493
2494 PP(pp_exit)
2495 {
2496     dSP;
2497     I32 anum;
2498
2499     if (MAXARG < 1)
2500         anum = 0;
2501     else {
2502         anum = SvIVx(POPs);
2503 #ifdef VMS
2504         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2505             anum = 0;
2506         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2507 #endif
2508     }
2509     PL_exit_flags |= PERL_EXIT_EXPECTED;
2510     my_exit(anum);
2511     PUSHs(&PL_sv_undef);
2512     RETURN;
2513 }
2514
2515 #ifdef NOTYET
2516 PP(pp_nswitch)
2517 {
2518     dSP;
2519     NV value = SvNVx(GvSV(cCOP->cop_gv));
2520     register I32 match = I_32(value);
2521
2522     if (value < 0.0) {
2523         if (((NV)match) > value)
2524             --match;            /* was fractional--truncate other way */
2525     }
2526     match -= cCOP->uop.scop.scop_offset;
2527     if (match < 0)
2528         match = 0;
2529     else if (match > cCOP->uop.scop.scop_max)
2530         match = cCOP->uop.scop.scop_max;
2531     PL_op = cCOP->uop.scop.scop_next[match];
2532     RETURNOP(PL_op);
2533 }
2534
2535 PP(pp_cswitch)
2536 {
2537     dSP;
2538     register I32 match;
2539
2540     if (PL_multiline)
2541         PL_op = PL_op->op_next;                 /* can't assume anything */
2542     else {
2543         STRLEN n_a;
2544         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2545         match -= cCOP->uop.scop.scop_offset;
2546         if (match < 0)
2547             match = 0;
2548         else if (match > cCOP->uop.scop.scop_max)
2549             match = cCOP->uop.scop.scop_max;
2550         PL_op = cCOP->uop.scop.scop_next[match];
2551     }
2552     RETURNOP(PL_op);
2553 }
2554 #endif
2555
2556 /* Eval. */
2557
2558 STATIC void
2559 S_save_lines(pTHX_ AV *array, SV *sv)
2560 {
2561     register char *s = SvPVX(sv);
2562     register char *send = SvPVX(sv) + SvCUR(sv);
2563     register char *t;
2564     register I32 line = 1;
2565
2566     while (s && s < send) {
2567         SV *tmpstr = NEWSV(85,0);
2568
2569         sv_upgrade(tmpstr, SVt_PVMG);
2570         t = strchr(s, '\n');
2571         if (t)
2572             t++;
2573         else
2574             t = send;
2575
2576         sv_setpvn(tmpstr, s, t - s);
2577         av_store(array, line++, tmpstr);
2578         s = t;
2579     }
2580 }
2581
2582 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2583 STATIC void *
2584 S_docatch_body(pTHX_ va_list args)
2585 {
2586     return docatch_body();
2587 }
2588 #endif
2589
2590 STATIC void *
2591 S_docatch_body(pTHX)
2592 {
2593     CALLRUNOPS(aTHX);
2594     return NULL;
2595 }
2596
2597 STATIC OP *
2598 S_docatch(pTHX_ OP *o)
2599 {
2600     int ret;
2601     OP *oldop = PL_op;
2602     OP *retop;
2603     volatile PERL_SI *cursi = PL_curstackinfo;
2604     dJMPENV;
2605
2606 #ifdef DEBUGGING
2607     assert(CATCH_GET == TRUE);
2608 #endif
2609     PL_op = o;
2610
2611     /* Normally, the leavetry at the end of this block of ops will
2612      * pop an op off the return stack and continue there. By setting
2613      * the op to Nullop, we force an exit from the inner runops()
2614      * loop. DAPM.
2615      */
2616     retop = pop_return();
2617     push_return(Nullop);
2618
2619 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2620  redo_body:
2621     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2622 #else
2623     JMPENV_PUSH(ret);
2624 #endif
2625     switch (ret) {
2626     case 0:
2627 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2628  redo_body:
2629         docatch_body();
2630 #endif
2631         break;
2632     case 3:
2633         /* die caught by an inner eval - continue inner loop */
2634         if (PL_restartop && cursi == PL_curstackinfo) {
2635             PL_op = PL_restartop;
2636             PL_restartop = 0;
2637             goto redo_body;
2638         }
2639         /* a die in this eval - continue in outer loop */
2640         if (!PL_restartop)
2641             break;
2642         /* FALL THROUGH */
2643     default:
2644         JMPENV_POP;
2645         PL_op = oldop;
2646         JMPENV_JUMP(ret);
2647         /* NOTREACHED */
2648     }
2649     JMPENV_POP;
2650     PL_op = oldop;
2651     return retop;
2652 }
2653
2654 OP *
2655 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2656 /* sv Text to convert to OP tree. */
2657 /* startop op_free() this to undo. */
2658 /* code Short string id of the caller. */
2659 {
2660     dSP;                                /* Make POPBLOCK work. */
2661     PERL_CONTEXT *cx;
2662     SV **newsp;
2663     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2664     I32 optype;
2665     OP dummy;
2666     OP *rop;
2667     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2668     char *tmpbuf = tbuf;
2669     char *safestr;
2670     int runtime;
2671     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2672
2673     ENTER;
2674     lex_start(sv);
2675     SAVETMPS;
2676     /* switch to eval mode */
2677
2678     if (PL_curcop == &PL_compiling) {
2679         SAVECOPSTASH_FREE(&PL_compiling);
2680         CopSTASH_set(&PL_compiling, PL_curstash);
2681     }
2682     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2683         SV *sv = sv_newmortal();
2684         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2685                        code, (unsigned long)++PL_evalseq,
2686                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2687         tmpbuf = SvPVX(sv);
2688     }
2689     else
2690         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2691     SAVECOPFILE_FREE(&PL_compiling);
2692     CopFILE_set(&PL_compiling, tmpbuf+2);
2693     SAVECOPLINE(&PL_compiling);
2694     CopLINE_set(&PL_compiling, 1);
2695     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2696        deleting the eval's FILEGV from the stash before gv_check() runs
2697        (i.e. before run-time proper). To work around the coredump that
2698        ensues, we always turn GvMULTI_on for any globals that were
2699        introduced within evals. See force_ident(). GSAR 96-10-12 */
2700     safestr = savepv(tmpbuf);
2701     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2702     SAVEHINTS();
2703 #ifdef OP_IN_REGISTER
2704     PL_opsave = op;
2705 #else
2706     SAVEVPTR(PL_op);
2707 #endif
2708     PL_hints &= HINT_UTF8;
2709
2710     /* we get here either during compilation, or via pp_regcomp at runtime */
2711     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2712     if (runtime)
2713         runcv = find_runcv(NULL);
2714
2715     PL_op = &dummy;
2716     PL_op->op_type = OP_ENTEREVAL;
2717     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2718     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2719     PUSHEVAL(cx, 0, Nullgv);
2720
2721     if (runtime)
2722         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2723     else
2724         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2725     POPBLOCK(cx,PL_curpm);
2726     POPEVAL(cx);
2727
2728     (*startop)->op_type = OP_NULL;
2729     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2730     lex_end();
2731     /* XXX DAPM do this properly one year */
2732     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2733     LEAVE;
2734     if (PL_curcop == &PL_compiling)
2735         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2736 #ifdef OP_IN_REGISTER
2737     op = PL_opsave;
2738 #endif
2739     return rop;
2740 }
2741
2742
2743 /*
2744 =for apidoc find_runcv
2745
2746 Locate the CV corresponding to the currently executing sub or eval.
2747 If db_seqp is non_null, skip CVs that are in the DB package and populate
2748 *db_seqp with the cop sequence number at the point that the DB:: code was
2749 entered. (allows debuggers to eval in the scope of the breakpoint rather
2750 than in in the scope of the debuger itself).
2751
2752 =cut
2753 */
2754
2755 CV*
2756 Perl_find_runcv(pTHX_ U32 *db_seqp)
2757 {
2758     I32          ix;
2759     PERL_SI      *si;
2760     PERL_CONTEXT *cx;
2761
2762     if (db_seqp)
2763         *db_seqp = PL_curcop->cop_seq;
2764     for (si = PL_curstackinfo; si; si = si->si_prev) {
2765         for (ix = si->si_cxix; ix >= 0; ix--) {
2766             cx = &(si->si_cxstack[ix]);
2767             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2768                 CV *cv = cx->blk_sub.cv;
2769                 /* skip DB:: code */
2770                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2771                     *db_seqp = cx->blk_oldcop->cop_seq;
2772                     continue;
2773                 }
2774                 return cv;
2775             }
2776             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2777                 return PL_compcv;
2778         }
2779     }
2780     return PL_main_cv;
2781 }
2782
2783
2784 /* Compile a require/do, an eval '', or a /(?{...})/.
2785  * In the last case, startop is non-null, and contains the address of
2786  * a pointer that should be set to the just-compiled code.
2787  * outside is the lexically enclosing CV (if any) that invoked us.
2788  */
2789
2790 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2791 STATIC OP *
2792 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2793 {
2794     dSP;
2795     OP *saveop = PL_op;
2796
2797     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2798                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2799                   : EVAL_INEVAL);
2800
2801     PUSHMARK(SP);
2802
2803     SAVESPTR(PL_compcv);
2804     PL_compcv = (CV*)NEWSV(1104,0);
2805     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2806     CvEVAL_on(PL_compcv);
2807     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2808     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2809
2810     CvOUTSIDE_SEQ(PL_compcv) = seq;
2811     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2812
2813     /* set up a scratch pad */
2814
2815     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2816
2817
2818     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2819
2820     /* make sure we compile in the right package */
2821
2822     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2823         SAVESPTR(PL_curstash);
2824         PL_curstash = CopSTASH(PL_curcop);
2825     }
2826     SAVESPTR(PL_beginav);
2827     PL_beginav = newAV();
2828     SAVEFREESV(PL_beginav);
2829     SAVEI32(PL_error_count);
2830
2831     /* try to compile it */
2832
2833     PL_eval_root = Nullop;
2834     PL_error_count = 0;
2835     PL_curcop = &PL_compiling;
2836     PL_curcop->cop_arybase = 0;
2837     if (saveop && saveop->op_flags & OPf_SPECIAL)
2838         PL_in_eval |= EVAL_KEEPERR;
2839     else
2840         sv_setpv(ERRSV,"");
2841     if (yyparse() || PL_error_count || !PL_eval_root) {
2842         SV **newsp;
2843         I32 gimme;
2844         PERL_CONTEXT *cx;
2845         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2846         STRLEN n_a;
2847
2848         PL_op = saveop;
2849         if (PL_eval_root) {
2850             op_free(PL_eval_root);
2851             PL_eval_root = Nullop;
2852         }
2853         SP = PL_stack_base + POPMARK;           /* pop original mark */
2854         if (!startop) {
2855             POPBLOCK(cx,PL_curpm);
2856             POPEVAL(cx);
2857             pop_return();
2858         }
2859         lex_end();
2860         LEAVE;
2861         if (optype == OP_REQUIRE) {
2862             char* msg = SvPVx(ERRSV, n_a);
2863             DIE(aTHX_ "%sCompilation failed in require",
2864                 *msg ? msg : "Unknown error\n");
2865         }
2866         else if (startop) {
2867             char* msg = SvPVx(ERRSV, n_a);
2868
2869             POPBLOCK(cx,PL_curpm);
2870             POPEVAL(cx);
2871             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2872                        (*msg ? msg : "Unknown error\n"));
2873         }
2874         else {
2875             char* msg = SvPVx(ERRSV, n_a);
2876             if (!*msg) {
2877                 sv_setpv(ERRSV, "Compilation error");
2878             }
2879         }
2880         RETPUSHUNDEF;
2881     }
2882     CopLINE_set(&PL_compiling, 0);
2883     if (startop) {
2884         *startop = PL_eval_root;
2885     } else
2886         SAVEFREEOP(PL_eval_root);
2887     if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE)
2888         /*
2889          * EVAL_INREQUIRE (the code is being required) is special-cased :
2890          * in this case we want scalar context to be forced, instead
2891          * of void context, so a proper return value is returned from
2892          * C<require> via this leaveeval op.
2893          */
2894         scalarvoid(PL_eval_root);
2895     else if (gimme & G_ARRAY)
2896         list(PL_eval_root);
2897     else
2898         scalar(PL_eval_root);
2899
2900     DEBUG_x(dump_eval());
2901
2902     /* Register with debugger: */
2903     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2904         CV *cv = get_cv("DB::postponed", FALSE);
2905         if (cv) {
2906             dSP;
2907             PUSHMARK(SP);
2908             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2909             PUTBACK;
2910             call_sv((SV*)cv, G_DISCARD);
2911         }
2912     }
2913
2914     /* compiled okay, so do it */
2915
2916     CvDEPTH(PL_compcv) = 1;
2917     SP = PL_stack_base + POPMARK;               /* pop original mark */
2918     PL_op = saveop;                     /* The caller may need it. */
2919     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2920
2921     RETURNOP(PL_eval_start);
2922 }
2923
2924 STATIC PerlIO *
2925 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2926 {
2927     STRLEN namelen = strlen(name);
2928     PerlIO *fp;
2929
2930     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2931         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2932         char *pmc = SvPV_nolen(pmcsv);
2933         Stat_t pmstat;
2934         Stat_t pmcstat;
2935         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2936             fp = PerlIO_open(name, mode);
2937         }
2938         else {
2939             if (PerlLIO_stat(name, &pmstat) < 0 ||
2940                 pmstat.st_mtime < pmcstat.st_mtime)
2941             {
2942                 fp = PerlIO_open(pmc, mode);
2943             }
2944             else {
2945                 fp = PerlIO_open(name, mode);
2946             }
2947         }
2948         SvREFCNT_dec(pmcsv);
2949     }
2950     else {
2951         fp = PerlIO_open(name, mode);
2952     }
2953     return fp;
2954 }
2955
2956 PP(pp_require)
2957 {
2958     dSP;
2959     register PERL_CONTEXT *cx;
2960     SV *sv;
2961     char *name;
2962     STRLEN len;
2963     char *tryname = Nullch;
2964     SV *namesv = Nullsv;
2965     SV** svp;
2966     I32 gimme = GIMME_V;
2967     PerlIO *tryrsfp = 0;
2968     STRLEN n_a;
2969     int filter_has_file = 0;
2970     GV *filter_child_proc = 0;
2971     SV *filter_state = 0;
2972     SV *filter_sub = 0;
2973     SV *hook_sv = 0;
2974     SV *encoding;
2975     OP *op;
2976
2977     sv = POPs;
2978     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2979         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2980             UV rev = 0, ver = 0, sver = 0;
2981             STRLEN len;
2982             U8 *s = (U8*)SvPVX(sv);
2983             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2984             if (s < end) {
2985                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2986                 s += len;
2987                 if (s < end) {
2988                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2989                     s += len;
2990                     if (s < end)
2991                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2992                 }
2993             }
2994             if (PERL_REVISION < rev
2995                 || (PERL_REVISION == rev
2996                     && (PERL_VERSION < ver
2997                         || (PERL_VERSION == ver
2998                             && PERL_SUBVERSION < sver))))
2999             {
3000                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3001                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3002                     PERL_VERSION, PERL_SUBVERSION);
3003             }
3004             if (ckWARN(WARN_PORTABLE))
3005                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3006                         "v-string in use/require non-portable");
3007             RETPUSHYES;
3008         }
3009         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3010             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3011                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3012                 + 0.00000099 < SvNV(sv))
3013             {
3014                 NV nrev = SvNV(sv);
3015                 UV rev = (UV)nrev;
3016                 NV nver = (nrev - rev) * 1000;
3017                 UV ver = (UV)(nver + 0.0009);
3018                 NV nsver = (nver - ver) * 1000;
3019                 UV sver = (UV)(nsver + 0.0009);
3020
3021                 /* help out with the "use 5.6" confusion */
3022                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3023                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3024                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3025                         "this is only v%d.%d.%d, stopped",
3026                         rev, ver, sver, rev, ver/100,
3027                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3028                 }
3029                 else {
3030                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3031                         "this is only v%d.%d.%d, stopped",
3032                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3033                         PERL_SUBVERSION);
3034                 }
3035             }
3036             RETPUSHYES;
3037         }
3038     }
3039     name = SvPV(sv, len);
3040     if (!(name && len > 0 && *name))
3041         DIE(aTHX_ "Null filename used");
3042     TAINT_PROPER("require");
3043     if (PL_op->op_type == OP_REQUIRE &&
3044       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3045       *svp != &PL_sv_undef)
3046         RETPUSHYES;
3047
3048     /* prepare to compile file */
3049
3050     if (path_is_absolute(name)) {
3051         tryname = name;
3052         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3053     }
3054 #ifdef MACOS_TRADITIONAL
3055     if (!tryrsfp) {
3056         char newname[256];
3057
3058         MacPerl_CanonDir(name, newname, 1);
3059         if (path_is_absolute(newname)) {
3060             tryname = newname;
3061             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3062         }
3063     }
3064 #endif
3065     if (!tryrsfp) {
3066         AV *ar = GvAVn(PL_incgv);
3067         I32 i;
3068 #ifdef VMS
3069         char *unixname;
3070         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3071 #endif
3072         {
3073             namesv = NEWSV(806, 0);
3074             for (i = 0; i <= AvFILL(ar); i++) {
3075                 SV *dirsv = *av_fetch(ar, i, TRUE);
3076
3077                 if (SvROK(dirsv)) {
3078                     int count;
3079                     SV *loader = dirsv;
3080
3081                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3082                         && !sv_isobject(loader))
3083                     {
3084                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3085                     }
3086
3087                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3088                                    PTR2UV(SvRV(dirsv)), name);
3089                     tryname = SvPVX(namesv);
3090                     tryrsfp = 0;
3091
3092                     ENTER;
3093                     SAVETMPS;
3094                     EXTEND(SP, 2);
3095
3096                     PUSHMARK(SP);
3097                     PUSHs(dirsv);
3098                     PUSHs(sv);
3099                     PUTBACK;
3100                     if (sv_isobject(loader))
3101                         count = call_method("INC", G_ARRAY);
3102                     else
3103                         count = call_sv(loader, G_ARRAY);
3104                     SPAGAIN;
3105
3106                     if (count > 0) {
3107                         int i = 0;
3108                         SV *arg;
3109
3110                         SP -= count - 1;
3111                         arg = SP[i++];
3112
3113                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3114                             arg = SvRV(arg);
3115                         }
3116
3117                         if (SvTYPE(arg) == SVt_PVGV) {
3118                             IO *io = GvIO((GV *)arg);
3119
3120                             ++filter_has_file;
3121
3122                             if (io) {
3123                                 tryrsfp = IoIFP(io);
3124                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3125                                     /* reading from a child process doesn't
3126                                        nest -- when returning from reading
3127                                        the inner module, the outer one is
3128                                        unreadable (closed?)  I've tried to
3129                                        save the gv to manage the lifespan of
3130                                        the pipe, but this didn't help. XXX */
3131                                     filter_child_proc = (GV *)arg;
3132                                     (void)SvREFCNT_inc(filter_child_proc);
3133                                 }
3134                                 else {
3135                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3136                                         PerlIO_close(IoOFP(io));
3137                                     }
3138                                     IoIFP(io) = Nullfp;
3139                                     IoOFP(io) = Nullfp;
3140                                 }
3141                             }
3142
3143                             if (i < count) {
3144                                 arg = SP[i++];
3145                             }
3146                         }
3147
3148                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3149                             filter_sub = arg;
3150                             (void)SvREFCNT_inc(filter_sub);
3151
3152                             if (i < count) {
3153                                 filter_state = SP[i];
3154                                 (void)SvREFCNT_inc(filter_state);
3155                             }
3156
3157                             if (tryrsfp == 0) {
3158                                 tryrsfp = PerlIO_open("/dev/null",
3159                                                       PERL_SCRIPT_MODE);
3160                             }
3161                         }
3162                     }
3163
3164                     PUTBACK;
3165                     FREETMPS;
3166                     LEAVE;
3167
3168                     if (tryrsfp) {
3169                         hook_sv = dirsv;
3170                         break;
3171                     }
3172
3173                     filter_has_file = 0;
3174                     if (filter_child_proc) {
3175                         SvREFCNT_dec(filter_child_proc);
3176                         filter_child_proc = 0;
3177                     }
3178                     if (filter_state) {
3179                         SvREFCNT_dec(filter_state);
3180                         filter_state = 0;
3181                     }
3182                     if (filter_sub) {
3183                         SvREFCNT_dec(filter_sub);
3184                         filter_sub = 0;
3185                     }
3186                 }
3187                 else {
3188                   if (!path_is_absolute(name)
3189 #ifdef MACOS_TRADITIONAL
3190                         /* We consider paths of the form :a:b ambiguous and interpret them first
3191                            as global then as local
3192                         */
3193                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3194 #endif
3195                   ) {
3196                     char *dir = SvPVx(dirsv, n_a);
3197 #ifdef MACOS_TRADITIONAL
3198                     char buf1[256];
3199                     char buf2[256];
3200
3201                     MacPerl_CanonDir(name, buf2, 1);
3202                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3203 #else
3204 #ifdef VMS
3205                     char *unixdir;
3206                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3207                         continue;
3208                     sv_setpv(namesv, unixdir);
3209                     sv_catpv(namesv, unixname);
3210 #else
3211                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3212 #endif
3213 #endif
3214                     TAINT_PROPER("require");
3215                     tryname = SvPVX(namesv);
3216                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3217                     if (tryrsfp) {
3218                         if (tryname[0] == '.' && tryname[1] == '/')
3219                             tryname += 2;
3220                         break;
3221                     }
3222                   }
3223                 }
3224             }
3225         }
3226     }
3227     SAVECOPFILE_FREE(&PL_compiling);
3228     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3229     SvREFCNT_dec(namesv);
3230     if (!tryrsfp) {
3231         if (PL_op->op_type == OP_REQUIRE) {
3232             char *msgstr = name;
3233             if (namesv) {                       /* did we lookup @INC? */
3234                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3235                 SV *dirmsgsv = NEWSV(0, 0);
3236                 AV *ar = GvAVn(PL_incgv);
3237                 I32 i;
3238                 sv_catpvn(msg, " in @INC", 8);
3239                 if (instr(SvPVX(msg), ".h "))
3240                     sv_catpv(msg, " (change .h to .ph maybe?)");
3241                 if (instr(SvPVX(msg), ".ph "))
3242                     sv_catpv(msg, " (did you run h2ph?)");
3243                 sv_catpv(msg, " (@INC contains:");
3244                 for (i = 0; i <= AvFILL(ar); i++) {
3245                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3246                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3247                     sv_catsv(msg, dirmsgsv);
3248                 }
3249                 sv_catpvn(msg, ")", 1);
3250                 SvREFCNT_dec(dirmsgsv);
3251                 msgstr = SvPV_nolen(msg);
3252             }
3253             DIE(aTHX_ "Can't locate %s", msgstr);
3254         }
3255
3256         RETPUSHUNDEF;
3257     }
3258     else
3259         SETERRNO(0, SS_NORMAL);
3260
3261     /* Assume success here to prevent recursive requirement. */
3262     len = strlen(name);
3263     /* Check whether a hook in @INC has already filled %INC */
3264     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3265         (void)hv_store(GvHVn(PL_incgv), name, len,
3266                        (hook_sv ? SvREFCNT_inc(hook_sv)
3267                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3268                        0 );
3269     }
3270
3271     ENTER;
3272     SAVETMPS;
3273     lex_start(sv_2mortal(newSVpvn("",0)));
3274     SAVEGENERICSV(PL_rsfp_filters);
3275     PL_rsfp_filters = Nullav;
3276
3277     PL_rsfp = tryrsfp;
3278     SAVEHINTS();
3279     PL_hints = 0;
3280     SAVESPTR(PL_compiling.cop_warnings);
3281     if (PL_dowarn & G_WARN_ALL_ON)
3282         PL_compiling.cop_warnings = pWARN_ALL ;
3283     else if (PL_dowarn & G_WARN_ALL_OFF)
3284         PL_compiling.cop_warnings = pWARN_NONE ;
3285     else if (PL_taint_warn)
3286         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3287     else
3288         PL_compiling.cop_warnings = pWARN_STD ;
3289     SAVESPTR(PL_compiling.cop_io);
3290     PL_compiling.cop_io = Nullsv;
3291
3292     if (filter_sub || filter_child_proc) {
3293         SV *datasv = filter_add(run_user_filter, Nullsv);
3294         IoLINES(datasv) = filter_has_file;
3295         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3296         IoTOP_GV(datasv) = (GV *)filter_state;
3297         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3298     }
3299
3300     /* switch to eval mode */
3301     push_return(PL_op->op_next);
3302     PUSHBLOCK(cx, CXt_EVAL, SP);
3303     PUSHEVAL(cx, name, Nullgv);
3304
3305     SAVECOPLINE(&PL_compiling);
3306     CopLINE_set(&PL_compiling, 0);
3307
3308     PUTBACK;
3309
3310     /* Store and reset encoding. */
3311     encoding = PL_encoding;
3312     PL_encoding = Nullsv;
3313
3314     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3315
3316     /* Restore encoding. */
3317     PL_encoding = encoding;
3318
3319     return op;
3320 }
3321
3322 PP(pp_dofile)
3323 {
3324     return pp_require();
3325 }
3326
3327 PP(pp_entereval)
3328 {
3329     dSP;
3330     register PERL_CONTEXT *cx;
3331     dPOPss;
3332     I32 gimme = GIMME_V, was = PL_sub_generation;
3333     char tbuf[TYPE_DIGITS(long) + 12];
3334     char *tmpbuf = tbuf;
3335     char *safestr;
3336     STRLEN len;
3337     OP *ret;
3338     CV* runcv;
3339     U32 seq;
3340
3341     if (!SvPV(sv,len))
3342         RETPUSHUNDEF;
3343     TAINT_PROPER("eval");
3344
3345     ENTER;
3346     lex_start(sv);
3347     SAVETMPS;
3348
3349     /* switch to eval mode */
3350
3351     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3352         SV *sv = sv_newmortal();
3353         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3354                        (unsigned long)++PL_evalseq,
3355                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3356         tmpbuf = SvPVX(sv);
3357     }
3358     else
3359         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3360     SAVECOPFILE_FREE(&PL_compiling);
3361     CopFILE_set(&PL_compiling, tmpbuf+2);
3362     SAVECOPLINE(&PL_compiling);
3363     CopLINE_set(&PL_compiling, 1);
3364     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3365        deleting the eval's FILEGV from the stash before gv_check() runs
3366        (i.e. before run-time proper). To work around the coredump that
3367        ensues, we always turn GvMULTI_on for any globals that were
3368        introduced within evals. See force_ident(). GSAR 96-10-12 */
3369     safestr = savepv(tmpbuf);
3370     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3371     SAVEHINTS();
3372     PL_hints = PL_op->op_targ;
3373     SAVESPTR(PL_compiling.cop_warnings);
3374     if (specialWARN(PL_curcop->cop_warnings))
3375         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3376     else {
3377         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3378         SAVEFREESV(PL_compiling.cop_warnings);
3379     }
3380     SAVESPTR(PL_compiling.cop_io);
3381     if (specialCopIO(PL_curcop->cop_io))
3382         PL_compiling.cop_io = PL_curcop->cop_io;
3383     else {
3384         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3385         SAVEFREESV(PL_compiling.cop_io);
3386     }
3387     /* special case: an eval '' executed within the DB package gets lexically
3388      * placed in the first non-DB CV rather than the current CV - this
3389      * allows the debugger to execute code, find lexicals etc, in the
3390      * scope of the code being debugged. Passing &seq gets find_runcv
3391      * to do the dirty work for us */
3392     runcv = find_runcv(&seq);
3393
3394     push_return(PL_op->op_next);
3395     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3396     PUSHEVAL(cx, 0, Nullgv);
3397
3398     /* prepare to compile string */
3399
3400     if (PERLDB_LINE && PL_curstash != PL_debstash)
3401         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3402     PUTBACK;
3403     ret = doeval(gimme, NULL, runcv, seq);
3404     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3405         && ret != PL_op->op_next) {     /* Successive compilation. */
3406         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3407     }
3408     return DOCATCH(ret);
3409 }
3410
3411 PP(pp_leaveeval)
3412 {
3413     dSP;
3414     register SV **mark;
3415     SV **newsp;
3416     PMOP *newpm;
3417     I32 gimme;
3418     register PERL_CONTEXT *cx;
3419     OP *retop;
3420     U8 save_flags = PL_op -> op_flags;
3421     I32 optype;
3422
3423     POPBLOCK(cx,newpm);
3424     POPEVAL(cx);
3425     retop = pop_return();
3426
3427     TAINT_NOT;
3428     if (gimme == G_VOID)
3429         MARK = newsp;
3430     else if (gimme == G_SCALAR) {
3431         MARK = newsp + 1;
3432         if (MARK <= SP) {
3433             if (SvFLAGS(TOPs) & SVs_TEMP)
3434                 *MARK = TOPs;
3435             else
3436                 *MARK = sv_mortalcopy(TOPs);
3437         }
3438         else {
3439             MEXTEND(mark,0);
3440             *MARK = &PL_sv_undef;
3441         }
3442         SP = MARK;
3443     }
3444     else {
3445         /* in case LEAVE wipes old return values */
3446         for (mark = newsp + 1; mark <= SP; mark++) {
3447             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3448                 *mark = sv_mortalcopy(*mark);
3449                 TAINT_NOT;      /* Each item is independent */
3450             }
3451         }
3452     }
3453     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3454
3455 #ifdef DEBUGGING
3456     assert(CvDEPTH(PL_compcv) == 1);
3457 #endif
3458     CvDEPTH(PL_compcv) = 0;
3459     lex_end();
3460
3461     if (optype == OP_REQUIRE &&
3462         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3463     {
3464         /* Unassume the success we assumed earlier. */
3465         SV *nsv = cx->blk_eval.old_namesv;
3466         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3467         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3468         /* die_where() did LEAVE, or we won't be here */
3469     }
3470     else {
3471         LEAVE;
3472         if (!(save_flags & OPf_SPECIAL))
3473             sv_setpv(ERRSV,"");
3474     }
3475
3476     RETURNOP(retop);
3477 }
3478
3479 PP(pp_entertry)
3480 {
3481     dSP;
3482     register PERL_CONTEXT *cx;
3483     I32 gimme = GIMME_V;
3484
3485     ENTER;
3486     SAVETMPS;
3487
3488     push_return(cLOGOP->op_other->op_next);
3489     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3490     PUSHEVAL(cx, 0, 0);
3491
3492     PL_in_eval = EVAL_INEVAL;
3493     sv_setpv(ERRSV,"");
3494     PUTBACK;
3495     return DOCATCH(PL_op->op_next);
3496 }
3497
3498 PP(pp_leavetry)
3499 {
3500     dSP;
3501     register SV **mark;
3502     SV **newsp;
3503     PMOP *newpm;
3504     OP* retop;
3505     I32 gimme;
3506     register PERL_CONTEXT *cx;
3507     I32 optype;
3508
3509     POPBLOCK(cx,newpm);
3510     POPEVAL(cx);
3511     retop = pop_return();
3512
3513     TAINT_NOT;
3514     if (gimme == G_VOID)
3515         SP = newsp;
3516     else if (gimme == G_SCALAR) {
3517         MARK = newsp + 1;
3518         if (MARK <= SP) {
3519             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3520                 *MARK = TOPs;
3521             else
3522                 *MARK = sv_mortalcopy(TOPs);
3523         }
3524         else {
3525             MEXTEND(mark,0);
3526             *MARK = &PL_sv_undef;
3527         }
3528         SP = MARK;
3529     }
3530     else {
3531         /* in case LEAVE wipes old return values */
3532         for (mark = newsp + 1; mark <= SP; mark++) {
3533             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3534                 *mark = sv_mortalcopy(*mark);
3535                 TAINT_NOT;      /* Each item is independent */
3536             }
3537         }
3538     }
3539     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3540
3541     LEAVE;
3542     sv_setpv(ERRSV,"");
3543     RETURNOP(retop);
3544 }
3545
3546 STATIC void
3547 S_doparseform(pTHX_ SV *sv)
3548 {
3549     STRLEN len;
3550     register char *s = SvPV_force(sv, len);
3551     register char *send = s + len;
3552     register char *base = Nullch;
3553     register I32 skipspaces = 0;
3554     bool noblank   = FALSE;
3555     bool repeat    = FALSE;
3556     bool postspace = FALSE;
3557     U16 *fops;
3558     register U16 *fpc;
3559     U16 *linepc = 0;
3560     register I32 arg;
3561     bool ischop;
3562
3563     if (len == 0)
3564         Perl_croak(aTHX_ "Null picture in formline");
3565
3566     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3567     fpc = fops;
3568
3569     if (s < send) {
3570         linepc = fpc;
3571         *fpc++ = FF_LINEMARK;
3572         noblank = repeat = FALSE;
3573         base = s;
3574     }
3575
3576     while (s <= send) {
3577         switch (*s++) {
3578         default:
3579             skipspaces = 0;
3580             continue;
3581
3582         case '~':
3583             if (*s == '~') {
3584                 repeat = TRUE;
3585                 *s = ' ';
3586             }
3587             noblank = TRUE;
3588             s[-1] = ' ';
3589             /* FALL THROUGH */
3590         case ' ': case '\t':
3591             skipspaces++;
3592             continue;
3593
3594         case '\n': case 0:
3595             arg = s - base;
3596             skipspaces++;
3597             arg -= skipspaces;
3598             if (arg) {
3599                 if (postspace)
3600                     *fpc++ = FF_SPACE;
3601                 *fpc++ = FF_LITERAL;
3602                 *fpc++ = (U16)arg;
3603             }
3604             postspace = FALSE;
3605             if (s <= send)
3606                 skipspaces--;
3607             if (skipspaces) {
3608                 *fpc++ = FF_SKIP;
3609                 *fpc++ = (U16)skipspaces;
3610             }
3611             skipspaces = 0;
3612             if (s <= send)
3613                 *fpc++ = FF_NEWLINE;
3614             if (noblank) {
3615                 *fpc++ = FF_BLANK;
3616                 if (repeat)
3617                     arg = fpc - linepc + 1;
3618                 else
3619                     arg = 0;
3620                 *fpc++ = (U16)arg;
3621             }
3622             if (s < send) {
3623                 linepc = fpc;
3624                 *fpc++ = FF_LINEMARK;
3625                 noblank = repeat = FALSE;
3626                 base = s;
3627             }
3628             else
3629                 s++;
3630             continue;
3631
3632         case '@':
3633         case '^':
3634             ischop = s[-1] == '^';
3635
3636             if (postspace) {
3637                 *fpc++ = FF_SPACE;
3638                 postspace = FALSE;
3639             }
3640             arg = (s - base) - 1;
3641             if (arg) {
3642                 *fpc++ = FF_LITERAL;
3643                 *fpc++ = (U16)arg;
3644             }
3645
3646             base = s - 1;
3647             *fpc++ = FF_FETCH;
3648             if (*s == '*') {
3649                 s++;
3650                 *fpc++ = 0;
3651                 *fpc++ = FF_LINEGLOB;
3652             }
3653             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3654                 arg = ischop ? 512 : 0;
3655                 base = s - 1;
3656                 while (*s == '#')
3657                     s++;
3658                 if (*s == '.') {
3659                     char *f;
3660                     s++;
3661                     f = s;
3662                     while (*s == '#')
3663                         s++;
3664                     arg |= 256 + (s - f);
3665                 }
3666                 *fpc++ = s - base;              /* fieldsize for FETCH */
3667                 *fpc++ = FF_DECIMAL;
3668                 *fpc++ = (U16)arg;
3669             }
3670             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3671                 arg = ischop ? 512 : 0;
3672                 base = s - 1;
3673                 s++;                                /* skip the '0' first */
3674                 while (*s == '#')
3675                     s++;
3676                 if (*s == '.') {
3677                     char *f;
3678                     s++;
3679                     f = s;
3680                     while (*s == '#')
3681                         s++;
3682                     arg |= 256 + (s - f);
3683                 }
3684                 *fpc++ = s - base;                /* fieldsize for FETCH */
3685                 *fpc++ = FF_0DECIMAL;
3686                 *fpc++ = (U16)arg;
3687             }
3688             else {
3689                 I32 prespace = 0;
3690                 bool ismore = FALSE;
3691
3692                 if (*s == '>') {
3693                     while (*++s == '>') ;
3694                     prespace = FF_SPACE;
3695                 }
3696                 else if (*s == '|') {
3697                     while (*++s == '|') ;
3698                     prespace = FF_HALFSPACE;
3699                     postspace = TRUE;
3700                 }
3701                 else {
3702                     if (*s == '<')
3703                         while (*++s == '<') ;
3704                     postspace = TRUE;
3705                 }
3706                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3707                     s += 3;
3708                     ismore = TRUE;
3709                 }
3710                 *fpc++ = s - base;              /* fieldsize for FETCH */
3711
3712                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3713
3714                 if (prespace)
3715                     *fpc++ = (U16)prespace;
3716                 *fpc++ = FF_ITEM;
3717                 if (ismore)
3718                     *fpc++ = FF_MORE;
3719                 if (ischop)
3720                     *fpc++ = FF_CHOP;
3721             }
3722             base = s;
3723             skipspaces = 0;
3724             continue;
3725         }
3726     }
3727     *fpc++ = FF_END;
3728
3729     arg = fpc - fops;
3730     { /* need to jump to the next word */
3731         int z;
3732         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3733         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3734         s = SvPVX(sv) + SvCUR(sv) + z;
3735     }
3736     Copy(fops, s, arg, U16);
3737     Safefree(fops);
3738     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3739     SvCOMPILED_on(sv);
3740 }
3741
3742 static I32
3743 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3744 {
3745     SV *datasv = FILTER_DATA(idx);
3746     int filter_has_file = IoLINES(datasv);
3747     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3748     SV *filter_state = (SV *)IoTOP_GV(datasv);
3749     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3750     int len = 0;
3751
3752     /* I was having segfault trouble under Linux 2.2.5 after a
3753        parse error occured.  (Had to hack around it with a test
3754        for PL_error_count == 0.)  Solaris doesn't segfault --
3755        not sure where the trouble is yet.  XXX */
3756
3757     if (filter_has_file) {
3758         len = FILTER_READ(idx+1, buf_sv, maxlen);
3759     }
3760
3761     if (filter_sub && len >= 0) {
3762         dSP;
3763         int count;
3764
3765         ENTER;
3766         SAVE_DEFSV;
3767         SAVETMPS;
3768         EXTEND(SP, 2);
3769
3770         DEFSV = buf_sv;
3771         PUSHMARK(SP);
3772         PUSHs(sv_2mortal(newSViv(maxlen)));
3773         if (filter_state) {
3774             PUSHs(filter_state);
3775         }
3776         PUTBACK;
3777         count = call_sv(filter_sub, G_SCALAR);
3778         SPAGAIN;
3779
3780         if (count > 0) {
3781             SV *out = POPs;
3782             if (SvOK(out)) {
3783                 len = SvIV(out);
3784             }
3785         }
3786
3787         PUTBACK;
3788         FREETMPS;
3789         LEAVE;
3790     }
3791
3792     if (len <= 0) {
3793         IoLINES(datasv) = 0;
3794         if (filter_child_proc) {
3795             SvREFCNT_dec(filter_child_proc);
3796             IoFMT_GV(datasv) = Nullgv;
3797         }
3798         if (filter_state) {
3799             SvREFCNT_dec(filter_state);
3800             IoTOP_GV(datasv) = Nullgv;
3801         }
3802         if (filter_sub) {
3803             SvREFCNT_dec(filter_sub);
3804             IoBOTTOM_GV(datasv) = Nullgv;
3805         }
3806         filter_del(run_user_filter);
3807     }
3808
3809     return len;
3810 }
3811
3812 /* perhaps someone can come up with a better name for
3813    this?  it is not really "absolute", per se ... */
3814 static bool
3815 S_path_is_absolute(pTHX_ char *name)
3816 {
3817     if (PERL_FILE_IS_ABSOLUTE(name)
3818 #ifdef MACOS_TRADITIONAL
3819         || (*name == ':'))
3820 #else
3821         || (*name == '.' && (name[1] == '/' ||
3822                              (name[1] == '.' && name[2] == '/'))))
3823 #endif
3824     {
3825         return TRUE;
3826     }
3827     else
3828         return FALSE;
3829 }