pp_ctl.c

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