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