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)
2888         scalarvoid(PL_eval_root);
2889     else if (gimme & G_ARRAY)
2890         list(PL_eval_root);
2891     else
2892         scalar(PL_eval_root);
2893
2894     DEBUG_x(dump_eval());
2895
2896     /* Register with debugger: */
2897     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2898         CV *cv = get_cv("DB::postponed", FALSE);
2899         if (cv) {
2900             dSP;
2901             PUSHMARK(SP);
2902             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2903             PUTBACK;
2904             call_sv((SV*)cv, G_DISCARD);
2905         }
2906     }
2907
2908     /* compiled okay, so do it */
2909
2910     CvDEPTH(PL_compcv) = 1;
2911     SP = PL_stack_base + POPMARK;               /* pop original mark */
2912     PL_op = saveop;                     /* The caller may need it. */
2913     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2914
2915     RETURNOP(PL_eval_start);
2916 }
2917
2918 STATIC PerlIO *
2919 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2920 {
2921     STRLEN namelen = strlen(name);
2922     PerlIO *fp;
2923
2924     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2925         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2926         char *pmc = SvPV_nolen(pmcsv);
2927         Stat_t pmstat;
2928         Stat_t pmcstat;
2929         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2930             fp = PerlIO_open(name, mode);
2931         }
2932         else {
2933             if (PerlLIO_stat(name, &pmstat) < 0 ||
2934                 pmstat.st_mtime < pmcstat.st_mtime)
2935             {
2936                 fp = PerlIO_open(pmc, mode);
2937             }
2938             else {
2939                 fp = PerlIO_open(name, mode);
2940             }
2941         }
2942         SvREFCNT_dec(pmcsv);
2943     }
2944     else {
2945         fp = PerlIO_open(name, mode);
2946     }
2947     return fp;
2948 }
2949
2950 PP(pp_require)
2951 {
2952     dSP;
2953     register PERL_CONTEXT *cx;
2954     SV *sv;
2955     char *name;
2956     STRLEN len;
2957     char *tryname = Nullch;
2958     SV *namesv = Nullsv;
2959     SV** svp;
2960     I32 gimme = GIMME_V;
2961     PerlIO *tryrsfp = 0;
2962     STRLEN n_a;
2963     int filter_has_file = 0;
2964     GV *filter_child_proc = 0;
2965     SV *filter_state = 0;
2966     SV *filter_sub = 0;
2967     SV *hook_sv = 0;
2968     SV *encoding;
2969     OP *op;
2970
2971     sv = POPs;
2972     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2973         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2974             UV rev = 0, ver = 0, sver = 0;
2975             STRLEN len;
2976             U8 *s = (U8*)SvPVX(sv);
2977             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2978             if (s < end) {
2979                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2980                 s += len;
2981                 if (s < end) {
2982                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2983                     s += len;
2984                     if (s < end)
2985                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2986                 }
2987             }
2988             if (PERL_REVISION < rev
2989                 || (PERL_REVISION == rev
2990                     && (PERL_VERSION < ver
2991                         || (PERL_VERSION == ver
2992                             && PERL_SUBVERSION < sver))))
2993             {
2994                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2995                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2996                     PERL_VERSION, PERL_SUBVERSION);
2997             }
2998             if (ckWARN(WARN_PORTABLE))
2999                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3000                         "v-string in use/require non-portable");
3001             RETPUSHYES;
3002         }
3003         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3004             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3005                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3006                 + 0.00000099 < SvNV(sv))
3007             {
3008                 NV nrev = SvNV(sv);
3009                 UV rev = (UV)nrev;
3010                 NV nver = (nrev - rev) * 1000;
3011                 UV ver = (UV)(nver + 0.0009);
3012                 NV nsver = (nver - ver) * 1000;
3013                 UV sver = (UV)(nsver + 0.0009);
3014
3015                 /* help out with the "use 5.6" confusion */
3016                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3017                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3018                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3019                         "this is only v%d.%d.%d, stopped",
3020                         rev, ver, sver, rev, ver/100,
3021                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3022                 }
3023                 else {
3024                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3025                         "this is only v%d.%d.%d, stopped",
3026                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3027                         PERL_SUBVERSION);
3028                 }
3029             }
3030             RETPUSHYES;
3031         }
3032     }
3033     name = SvPV(sv, len);
3034     if (!(name && len > 0 && *name))
3035         DIE(aTHX_ "Null filename used");
3036     TAINT_PROPER("require");
3037     if (PL_op->op_type == OP_REQUIRE &&
3038       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3039       *svp != &PL_sv_undef)
3040         RETPUSHYES;
3041
3042     /* prepare to compile file */
3043
3044     if (path_is_absolute(name)) {
3045         tryname = name;
3046         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3047     }
3048 #ifdef MACOS_TRADITIONAL
3049     if (!tryrsfp) {
3050         char newname[256];
3051
3052         MacPerl_CanonDir(name, newname, 1);
3053         if (path_is_absolute(newname)) {
3054             tryname = newname;
3055             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3056         }
3057     }
3058 #endif
3059     if (!tryrsfp) {
3060         AV *ar = GvAVn(PL_incgv);
3061         I32 i;
3062 #ifdef VMS
3063         char *unixname;
3064         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3065 #endif
3066         {
3067             namesv = NEWSV(806, 0);
3068             for (i = 0; i <= AvFILL(ar); i++) {
3069                 SV *dirsv = *av_fetch(ar, i, TRUE);
3070
3071                 if (SvROK(dirsv)) {
3072                     int count;
3073                     SV *loader = dirsv;
3074
3075                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3076                         && !sv_isobject(loader))
3077                     {
3078                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3079                     }
3080
3081                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3082                                    PTR2UV(SvRV(dirsv)), name);
3083                     tryname = SvPVX(namesv);
3084                     tryrsfp = 0;
3085
3086                     ENTER;
3087                     SAVETMPS;
3088                     EXTEND(SP, 2);
3089
3090                     PUSHMARK(SP);
3091                     PUSHs(dirsv);
3092                     PUSHs(sv);
3093                     PUTBACK;
3094                     if (sv_isobject(loader))
3095                         count = call_method("INC", G_ARRAY);
3096                     else
3097                         count = call_sv(loader, G_ARRAY);
3098                     SPAGAIN;
3099
3100                     if (count > 0) {
3101                         int i = 0;
3102                         SV *arg;
3103
3104                         SP -= count - 1;
3105                         arg = SP[i++];
3106
3107                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3108                             arg = SvRV(arg);
3109                         }
3110
3111                         if (SvTYPE(arg) == SVt_PVGV) {
3112                             IO *io = GvIO((GV *)arg);
3113
3114                             ++filter_has_file;
3115
3116                             if (io) {
3117                                 tryrsfp = IoIFP(io);
3118                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3119                                     /* reading from a child process doesn't
3120                                        nest -- when returning from reading
3121                                        the inner module, the outer one is
3122                                        unreadable (closed?)  I've tried to
3123                                        save the gv to manage the lifespan of
3124                                        the pipe, but this didn't help. XXX */
3125                                     filter_child_proc = (GV *)arg;
3126                                     (void)SvREFCNT_inc(filter_child_proc);
3127                                 }
3128                                 else {
3129                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3130                                         PerlIO_close(IoOFP(io));
3131                                     }
3132                                     IoIFP(io) = Nullfp;
3133                                     IoOFP(io) = Nullfp;
3134                                 }
3135                             }
3136
3137                             if (i < count) {
3138                                 arg = SP[i++];
3139                             }
3140                         }
3141
3142                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3143                             filter_sub = arg;
3144                             (void)SvREFCNT_inc(filter_sub);
3145
3146                             if (i < count) {
3147                                 filter_state = SP[i];
3148                                 (void)SvREFCNT_inc(filter_state);
3149                             }
3150
3151                             if (tryrsfp == 0) {
3152                                 tryrsfp = PerlIO_open("/dev/null",
3153                                                       PERL_SCRIPT_MODE);
3154                             }
3155                         }
3156                     }
3157
3158                     PUTBACK;
3159                     FREETMPS;
3160                     LEAVE;
3161
3162                     if (tryrsfp) {
3163                         hook_sv = dirsv;
3164                         break;
3165                     }
3166
3167                     filter_has_file = 0;
3168                     if (filter_child_proc) {
3169                         SvREFCNT_dec(filter_child_proc);
3170                         filter_child_proc = 0;
3171                     }
3172                     if (filter_state) {
3173                         SvREFCNT_dec(filter_state);
3174                         filter_state = 0;
3175                     }
3176                     if (filter_sub) {
3177                         SvREFCNT_dec(filter_sub);
3178                         filter_sub = 0;
3179                     }
3180                 }
3181                 else {
3182                   if (!path_is_absolute(name)
3183 #ifdef MACOS_TRADITIONAL
3184                         /* We consider paths of the form :a:b ambiguous and interpret them first
3185                            as global then as local
3186                         */
3187                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3188 #endif
3189                   ) {
3190                     char *dir = SvPVx(dirsv, n_a);
3191 #ifdef MACOS_TRADITIONAL
3192                     char buf1[256];
3193                     char buf2[256];
3194
3195                     MacPerl_CanonDir(name, buf2, 1);
3196                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3197 #else
3198 #ifdef VMS
3199                     char *unixdir;
3200                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3201                         continue;
3202                     sv_setpv(namesv, unixdir);
3203                     sv_catpv(namesv, unixname);
3204 #else
3205                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3206 #endif
3207 #endif
3208                     TAINT_PROPER("require");
3209                     tryname = SvPVX(namesv);
3210                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3211                     if (tryrsfp) {
3212                         if (tryname[0] == '.' && tryname[1] == '/')
3213                             tryname += 2;
3214                         break;
3215                     }
3216                   }
3217                 }
3218             }
3219         }
3220     }
3221     SAVECOPFILE_FREE(&PL_compiling);
3222     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3223     SvREFCNT_dec(namesv);
3224     if (!tryrsfp) {
3225         if (PL_op->op_type == OP_REQUIRE) {
3226             char *msgstr = name;
3227             if (namesv) {                       /* did we lookup @INC? */
3228                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3229                 SV *dirmsgsv = NEWSV(0, 0);
3230                 AV *ar = GvAVn(PL_incgv);
3231                 I32 i;
3232                 sv_catpvn(msg, " in @INC", 8);
3233                 if (instr(SvPVX(msg), ".h "))
3234                     sv_catpv(msg, " (change .h to .ph maybe?)");
3235                 if (instr(SvPVX(msg), ".ph "))
3236                     sv_catpv(msg, " (did you run h2ph?)");
3237                 sv_catpv(msg, " (@INC contains:");
3238                 for (i = 0; i <= AvFILL(ar); i++) {
3239                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3240                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3241                     sv_catsv(msg, dirmsgsv);
3242                 }
3243                 sv_catpvn(msg, ")", 1);
3244                 SvREFCNT_dec(dirmsgsv);
3245                 msgstr = SvPV_nolen(msg);
3246             }
3247             DIE(aTHX_ "Can't locate %s", msgstr);
3248         }
3249
3250         RETPUSHUNDEF;
3251     }
3252     else
3253         SETERRNO(0, SS_NORMAL);
3254
3255     /* Assume success here to prevent recursive requirement. */
3256     len = strlen(name);
3257     /* Check whether a hook in @INC has already filled %INC */
3258     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3259         (void)hv_store(GvHVn(PL_incgv), name, len,
3260                        (hook_sv ? SvREFCNT_inc(hook_sv)
3261                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3262                        0 );
3263     }
3264
3265     ENTER;
3266     SAVETMPS;
3267     lex_start(sv_2mortal(newSVpvn("",0)));
3268     SAVEGENERICSV(PL_rsfp_filters);
3269     PL_rsfp_filters = Nullav;
3270
3271     PL_rsfp = tryrsfp;
3272     SAVEHINTS();
3273     PL_hints = 0;
3274     SAVESPTR(PL_compiling.cop_warnings);
3275     if (PL_dowarn & G_WARN_ALL_ON)
3276         PL_compiling.cop_warnings = pWARN_ALL ;
3277     else if (PL_dowarn & G_WARN_ALL_OFF)
3278         PL_compiling.cop_warnings = pWARN_NONE ;
3279     else if (PL_taint_warn)
3280         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3281     else
3282         PL_compiling.cop_warnings = pWARN_STD ;
3283     SAVESPTR(PL_compiling.cop_io);
3284     PL_compiling.cop_io = Nullsv;
3285
3286     if (filter_sub || filter_child_proc) {
3287         SV *datasv = filter_add(run_user_filter, Nullsv);
3288         IoLINES(datasv) = filter_has_file;
3289         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3290         IoTOP_GV(datasv) = (GV *)filter_state;
3291         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3292     }
3293
3294     /* switch to eval mode */
3295     push_return(PL_op->op_next);
3296     PUSHBLOCK(cx, CXt_EVAL, SP);
3297     PUSHEVAL(cx, name, Nullgv);
3298
3299     SAVECOPLINE(&PL_compiling);
3300     CopLINE_set(&PL_compiling, 0);
3301
3302     PUTBACK;
3303
3304     /* Store and reset encoding. */
3305     encoding = PL_encoding;
3306     PL_encoding = Nullsv;
3307
3308     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3309
3310     /* Restore encoding. */
3311     PL_encoding = encoding;
3312
3313     return op;
3314 }
3315
3316 PP(pp_dofile)
3317 {
3318     return pp_require();
3319 }
3320
3321 PP(pp_entereval)
3322 {
3323     dSP;
3324     register PERL_CONTEXT *cx;
3325     dPOPss;
3326     I32 gimme = GIMME_V, was = PL_sub_generation;
3327     char tbuf[TYPE_DIGITS(long) + 12];
3328     char *tmpbuf = tbuf;
3329     char *safestr;
3330     STRLEN len;
3331     OP *ret;
3332     CV* runcv;
3333     U32 seq;
3334
3335     if (!SvPV(sv,len))
3336         RETPUSHUNDEF;
3337     TAINT_PROPER("eval");
3338
3339     ENTER;
3340     lex_start(sv);
3341     SAVETMPS;
3342
3343     /* switch to eval mode */
3344
3345     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3346         SV *sv = sv_newmortal();
3347         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3348                        (unsigned long)++PL_evalseq,
3349                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3350         tmpbuf = SvPVX(sv);
3351     }
3352     else
3353         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3354     SAVECOPFILE_FREE(&PL_compiling);
3355     CopFILE_set(&PL_compiling, tmpbuf+2);
3356     SAVECOPLINE(&PL_compiling);
3357     CopLINE_set(&PL_compiling, 1);
3358     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3359        deleting the eval's FILEGV from the stash before gv_check() runs
3360        (i.e. before run-time proper). To work around the coredump that
3361        ensues, we always turn GvMULTI_on for any globals that were
3362        introduced within evals. See force_ident(). GSAR 96-10-12 */
3363     safestr = savepv(tmpbuf);
3364     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3365     SAVEHINTS();
3366     PL_hints = PL_op->op_targ;
3367     SAVESPTR(PL_compiling.cop_warnings);
3368     if (specialWARN(PL_curcop->cop_warnings))
3369         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3370     else {
3371         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3372         SAVEFREESV(PL_compiling.cop_warnings);
3373     }
3374     SAVESPTR(PL_compiling.cop_io);
3375     if (specialCopIO(PL_curcop->cop_io))
3376         PL_compiling.cop_io = PL_curcop->cop_io;
3377     else {
3378         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3379         SAVEFREESV(PL_compiling.cop_io);
3380     }
3381     /* special case: an eval '' executed within the DB package gets lexically
3382      * placed in the first non-DB CV rather than the current CV - this
3383      * allows the debugger to execute code, find lexicals etc, in the
3384      * scope of the code being debugged. Passing &seq gets find_runcv
3385      * to do the dirty work for us */
3386     runcv = find_runcv(&seq);
3387
3388     push_return(PL_op->op_next);
3389     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3390     PUSHEVAL(cx, 0, Nullgv);
3391
3392     /* prepare to compile string */
3393
3394     if (PERLDB_LINE && PL_curstash != PL_debstash)
3395         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3396     PUTBACK;
3397     ret = doeval(gimme, NULL, runcv, seq);
3398     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3399         && ret != PL_op->op_next) {     /* Successive compilation. */
3400         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3401     }
3402     return DOCATCH(ret);
3403 }
3404
3405 PP(pp_leaveeval)
3406 {
3407     dSP;
3408     register SV **mark;
3409     SV **newsp;
3410     PMOP *newpm;
3411     I32 gimme;
3412     register PERL_CONTEXT *cx;
3413     OP *retop;
3414     U8 save_flags = PL_op -> op_flags;
3415     I32 optype;
3416
3417     POPBLOCK(cx,newpm);
3418     POPEVAL(cx);
3419     retop = pop_return();
3420
3421     TAINT_NOT;
3422     if (gimme == G_VOID)
3423         MARK = newsp;
3424     else if (gimme == G_SCALAR) {
3425         MARK = newsp + 1;
3426         if (MARK <= SP) {
3427             if (SvFLAGS(TOPs) & SVs_TEMP)
3428                 *MARK = TOPs;
3429             else
3430                 *MARK = sv_mortalcopy(TOPs);
3431         }
3432         else {
3433             MEXTEND(mark,0);
3434             *MARK = &PL_sv_undef;
3435         }
3436         SP = MARK;
3437     }
3438     else {
3439         /* in case LEAVE wipes old return values */
3440         for (mark = newsp + 1; mark <= SP; mark++) {
3441             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3442                 *mark = sv_mortalcopy(*mark);
3443                 TAINT_NOT;      /* Each item is independent */
3444             }
3445         }
3446     }
3447     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3448
3449 #ifdef DEBUGGING
3450     assert(CvDEPTH(PL_compcv) == 1);
3451 #endif
3452     CvDEPTH(PL_compcv) = 0;
3453     lex_end();
3454
3455     if (optype == OP_REQUIRE &&
3456         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3457     {
3458         /* Unassume the success we assumed earlier. */
3459         SV *nsv = cx->blk_eval.old_namesv;
3460         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3461         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3462         /* die_where() did LEAVE, or we won't be here */
3463     }
3464     else {
3465         LEAVE;
3466         if (!(save_flags & OPf_SPECIAL))
3467             sv_setpv(ERRSV,"");
3468     }
3469
3470     RETURNOP(retop);
3471 }
3472
3473 PP(pp_entertry)
3474 {
3475     dSP;
3476     register PERL_CONTEXT *cx;
3477     I32 gimme = GIMME_V;
3478
3479     ENTER;
3480     SAVETMPS;
3481
3482     push_return(cLOGOP->op_other->op_next);
3483     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3484     PUSHEVAL(cx, 0, 0);
3485
3486     PL_in_eval = EVAL_INEVAL;
3487     sv_setpv(ERRSV,"");
3488     PUTBACK;
3489     return DOCATCH(PL_op->op_next);
3490 }
3491
3492 PP(pp_leavetry)
3493 {
3494     dSP;
3495     register SV **mark;
3496     SV **newsp;
3497     PMOP *newpm;
3498     OP* retop;
3499     I32 gimme;
3500     register PERL_CONTEXT *cx;
3501     I32 optype;
3502
3503     POPBLOCK(cx,newpm);
3504     POPEVAL(cx);
3505     retop = pop_return();
3506
3507     TAINT_NOT;
3508     if (gimme == G_VOID)
3509         SP = newsp;
3510     else if (gimme == G_SCALAR) {
3511         MARK = newsp + 1;
3512         if (MARK <= SP) {
3513             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3514                 *MARK = TOPs;
3515             else
3516                 *MARK = sv_mortalcopy(TOPs);
3517         }
3518         else {
3519             MEXTEND(mark,0);
3520             *MARK = &PL_sv_undef;
3521         }
3522         SP = MARK;
3523     }
3524     else {
3525         /* in case LEAVE wipes old return values */
3526         for (mark = newsp + 1; mark <= SP; mark++) {
3527             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3528                 *mark = sv_mortalcopy(*mark);
3529                 TAINT_NOT;      /* Each item is independent */
3530             }
3531         }
3532     }
3533     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3534
3535     LEAVE;
3536     sv_setpv(ERRSV,"");
3537     RETURNOP(retop);
3538 }
3539
3540 STATIC void
3541 S_doparseform(pTHX_ SV *sv)
3542 {
3543     STRLEN len;
3544     register char *s = SvPV_force(sv, len);
3545     register char *send = s + len;
3546     register char *base = Nullch;
3547     register I32 skipspaces = 0;
3548     bool noblank   = FALSE;
3549     bool repeat    = FALSE;
3550     bool postspace = FALSE;
3551     U16 *fops;
3552     register U16 *fpc;
3553     U16 *linepc = 0;
3554     register I32 arg;
3555     bool ischop;
3556
3557     if (len == 0)
3558         Perl_croak(aTHX_ "Null picture in formline");
3559
3560     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3561     fpc = fops;
3562
3563     if (s < send) {
3564         linepc = fpc;
3565         *fpc++ = FF_LINEMARK;
3566         noblank = repeat = FALSE;
3567         base = s;
3568     }
3569
3570     while (s <= send) {
3571         switch (*s++) {
3572         default:
3573             skipspaces = 0;
3574             continue;
3575
3576         case '~':
3577             if (*s == '~') {
3578                 repeat = TRUE;
3579                 *s = ' ';
3580             }
3581             noblank = TRUE;
3582             s[-1] = ' ';
3583             /* FALL THROUGH */
3584         case ' ': case '\t':
3585             skipspaces++;
3586             continue;
3587
3588         case '\n': case 0:
3589             arg = s - base;
3590             skipspaces++;
3591             arg -= skipspaces;
3592             if (arg) {
3593                 if (postspace)
3594                     *fpc++ = FF_SPACE;
3595                 *fpc++ = FF_LITERAL;
3596                 *fpc++ = (U16)arg;
3597             }
3598             postspace = FALSE;
3599             if (s <= send)
3600                 skipspaces--;
3601             if (skipspaces) {
3602                 *fpc++ = FF_SKIP;
3603                 *fpc++ = (U16)skipspaces;
3604             }
3605             skipspaces = 0;
3606             if (s <= send)
3607                 *fpc++ = FF_NEWLINE;
3608             if (noblank) {
3609                 *fpc++ = FF_BLANK;
3610                 if (repeat)
3611                     arg = fpc - linepc + 1;
3612                 else
3613                     arg = 0;
3614                 *fpc++ = (U16)arg;
3615             }
3616             if (s < send) {
3617                 linepc = fpc;
3618                 *fpc++ = FF_LINEMARK;
3619                 noblank = repeat = FALSE;
3620                 base = s;
3621             }
3622             else
3623                 s++;
3624             continue;
3625
3626         case '@':
3627         case '^':
3628             ischop = s[-1] == '^';
3629
3630             if (postspace) {
3631                 *fpc++ = FF_SPACE;
3632                 postspace = FALSE;
3633             }
3634             arg = (s - base) - 1;
3635             if (arg) {
3636                 *fpc++ = FF_LITERAL;
3637                 *fpc++ = (U16)arg;
3638             }
3639
3640             base = s - 1;
3641             *fpc++ = FF_FETCH;
3642             if (*s == '*') {
3643                 s++;
3644                 *fpc++ = 0;
3645                 *fpc++ = FF_LINEGLOB;
3646             }
3647             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3648                 arg = ischop ? 512 : 0;
3649                 base = s - 1;
3650                 while (*s == '#')
3651                     s++;
3652                 if (*s == '.') {
3653                     char *f;
3654                     s++;
3655                     f = s;
3656                     while (*s == '#')
3657                         s++;
3658                     arg |= 256 + (s - f);
3659                 }
3660                 *fpc++ = s - base;              /* fieldsize for FETCH */
3661                 *fpc++ = FF_DECIMAL;
3662                 *fpc++ = (U16)arg;
3663             }
3664             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3665                 arg = ischop ? 512 : 0;
3666                 base = s - 1;
3667                 s++;                                /* skip the '0' first */
3668                 while (*s == '#')
3669                     s++;
3670                 if (*s == '.') {
3671                     char *f;
3672                     s++;
3673                     f = s;
3674                     while (*s == '#')
3675                         s++;
3676                     arg |= 256 + (s - f);
3677                 }
3678                 *fpc++ = s - base;                /* fieldsize for FETCH */
3679                 *fpc++ = FF_0DECIMAL;
3680                 *fpc++ = (U16)arg;
3681             }
3682             else {
3683                 I32 prespace = 0;
3684                 bool ismore = FALSE;
3685
3686                 if (*s == '>') {
3687                     while (*++s == '>') ;
3688                     prespace = FF_SPACE;
3689                 }
3690                 else if (*s == '|') {
3691                     while (*++s == '|') ;
3692                     prespace = FF_HALFSPACE;
3693                     postspace = TRUE;
3694                 }
3695                 else {
3696                     if (*s == '<')
3697                         while (*++s == '<') ;
3698                     postspace = TRUE;
3699                 }
3700                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3701                     s += 3;
3702                     ismore = TRUE;
3703                 }
3704                 *fpc++ = s - base;              /* fieldsize for FETCH */
3705
3706                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3707
3708                 if (prespace)
3709                     *fpc++ = (U16)prespace;
3710                 *fpc++ = FF_ITEM;
3711                 if (ismore)
3712                     *fpc++ = FF_MORE;
3713                 if (ischop)
3714                     *fpc++ = FF_CHOP;
3715             }
3716             base = s;
3717             skipspaces = 0;
3718             continue;
3719         }
3720     }
3721     *fpc++ = FF_END;
3722
3723     arg = fpc - fops;
3724     { /* need to jump to the next word */
3725         int z;
3726         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3727         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3728         s = SvPVX(sv) + SvCUR(sv) + z;
3729     }
3730     Copy(fops, s, arg, U16);
3731     Safefree(fops);
3732     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3733     SvCOMPILED_on(sv);
3734 }
3735
3736 static I32
3737 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3738 {
3739     SV *datasv = FILTER_DATA(idx);
3740     int filter_has_file = IoLINES(datasv);
3741     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3742     SV *filter_state = (SV *)IoTOP_GV(datasv);
3743     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3744     int len = 0;
3745
3746     /* I was having segfault trouble under Linux 2.2.5 after a
3747        parse error occured.  (Had to hack around it with a test
3748        for PL_error_count == 0.)  Solaris doesn't segfault --
3749        not sure where the trouble is yet.  XXX */
3750
3751     if (filter_has_file) {
3752         len = FILTER_READ(idx+1, buf_sv, maxlen);
3753     }
3754
3755     if (filter_sub && len >= 0) {
3756         dSP;
3757         int count;
3758
3759         ENTER;
3760         SAVE_DEFSV;
3761         SAVETMPS;
3762         EXTEND(SP, 2);
3763
3764         DEFSV = buf_sv;
3765         PUSHMARK(SP);
3766         PUSHs(sv_2mortal(newSViv(maxlen)));
3767         if (filter_state) {
3768             PUSHs(filter_state);
3769         }
3770         PUTBACK;
3771         count = call_sv(filter_sub, G_SCALAR);
3772         SPAGAIN;
3773
3774         if (count > 0) {
3775             SV *out = POPs;
3776             if (SvOK(out)) {
3777                 len = SvIV(out);
3778             }
3779         }
3780
3781         PUTBACK;
3782         FREETMPS;
3783         LEAVE;
3784     }
3785
3786     if (len <= 0) {
3787         IoLINES(datasv) = 0;
3788         if (filter_child_proc) {
3789             SvREFCNT_dec(filter_child_proc);
3790             IoFMT_GV(datasv) = Nullgv;
3791         }
3792         if (filter_state) {
3793             SvREFCNT_dec(filter_state);
3794             IoTOP_GV(datasv) = Nullgv;
3795         }
3796         if (filter_sub) {
3797             SvREFCNT_dec(filter_sub);
3798             IoBOTTOM_GV(datasv) = Nullgv;
3799         }
3800         filter_del(run_user_filter);
3801     }
3802
3803     return len;
3804 }
3805
3806 /* perhaps someone can come up with a better name for
3807    this?  it is not really "absolute", per se ... */
3808 static bool
3809 S_path_is_absolute(pTHX_ char *name)
3810 {
3811     if (PERL_FILE_IS_ABSOLUTE(name)
3812 #ifdef MACOS_TRADITIONAL
3813         || (*name == ':'))
3814 #else
3815         || (*name == '.' && (name[1] == '/' ||
3816                              (name[1] == '.' && name[2] == '/'))))
3817 #endif
3818     {
3819         return TRUE;
3820     }
3821     else
3822         return FALSE;
3823 }