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         (void)SvREFCNT_inc(cv);
1705         PAD_SET_CUR(CvPADLIST(cv),1);
1706         RETURNOP(CvSTART(cv));
1707     }
1708     else
1709         return NORMAL;
1710 }
1711
1712 PP(pp_scope)
1713 {
1714     return NORMAL;
1715 }
1716
1717 PP(pp_enteriter)
1718 {
1719     dSP; dMARK;
1720     register PERL_CONTEXT *cx;
1721     I32 gimme = GIMME_V;
1722     SV **svp;
1723     U32 cxtype = CXt_LOOP;
1724 #ifdef USE_ITHREADS
1725     void *iterdata;
1726 #endif
1727
1728     ENTER;
1729     SAVETMPS;
1730
1731     if (PL_op->op_targ) {
1732         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1733             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1734             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1735                     SVs_PADSTALE, SVs_PADSTALE);
1736         }
1737 #ifndef USE_ITHREADS
1738         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1739         SAVESPTR(*svp);
1740 #else
1741         SAVEPADSV(PL_op->op_targ);
1742         iterdata = INT2PTR(void*, PL_op->op_targ);
1743         cxtype |= CXp_PADVAR;
1744 #endif
1745     }
1746     else {
1747         GV *gv = (GV*)POPs;
1748         svp = &GvSV(gv);                        /* symbol table variable */
1749         SAVEGENERICSV(*svp);
1750         *svp = NEWSV(0,0);
1751 #ifdef USE_ITHREADS
1752         iterdata = (void*)gv;
1753 #endif
1754     }
1755
1756     ENTER;
1757
1758     PUSHBLOCK(cx, cxtype, SP);
1759 #ifdef USE_ITHREADS
1760     PUSHLOOP(cx, iterdata, MARK);
1761 #else
1762     PUSHLOOP(cx, svp, MARK);
1763 #endif
1764     if (PL_op->op_flags & OPf_STACKED) {
1765         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1766         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1767             dPOPss;
1768             if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
1769                  if (SvNV(sv) < IV_MIN ||
1770                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1771                      DIE(aTHX_ "Range iterator outside integer range");
1772                  cx->blk_loop.iterix = SvIV(sv);
1773                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1774             }
1775             else
1776                 cx->blk_loop.iterlval = newSVsv(sv);
1777         }
1778     }
1779     else {
1780         cx->blk_loop.iterary = PL_curstack;
1781         AvFILLp(PL_curstack) = SP - PL_stack_base;
1782         cx->blk_loop.iterix = MARK - PL_stack_base;
1783     }
1784
1785     RETURN;
1786 }
1787
1788 PP(pp_enterloop)
1789 {
1790     dSP;
1791     register PERL_CONTEXT *cx;
1792     I32 gimme = GIMME_V;
1793
1794     ENTER;
1795     SAVETMPS;
1796     ENTER;
1797
1798     PUSHBLOCK(cx, CXt_LOOP, SP);
1799     PUSHLOOP(cx, 0, SP);
1800
1801     RETURN;
1802 }
1803
1804 PP(pp_leaveloop)
1805 {
1806     dSP;
1807     register PERL_CONTEXT *cx;
1808     I32 gimme;
1809     SV **newsp;
1810     PMOP *newpm;
1811     SV **mark;
1812
1813     POPBLOCK(cx,newpm);
1814     mark = newsp;
1815     newsp = PL_stack_base + cx->blk_loop.resetsp;
1816
1817     TAINT_NOT;
1818     if (gimme == G_VOID)
1819         ; /* do nothing */
1820     else if (gimme == G_SCALAR) {
1821         if (mark < SP)
1822             *++newsp = sv_mortalcopy(*SP);
1823         else
1824             *++newsp = &PL_sv_undef;
1825     }
1826     else {
1827         while (mark < SP) {
1828             *++newsp = sv_mortalcopy(*++mark);
1829             TAINT_NOT;          /* Each item is independent */
1830         }
1831     }
1832     SP = newsp;
1833     PUTBACK;
1834
1835     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1836     PL_curpm = newpm;   /* ... and pop $1 et al */
1837
1838     LEAVE;
1839     LEAVE;
1840
1841     return NORMAL;
1842 }
1843
1844 PP(pp_return)
1845 {
1846     dSP; dMARK;
1847     I32 cxix;
1848     register PERL_CONTEXT *cx;
1849     bool popsub2 = FALSE;
1850     bool clear_errsv = FALSE;
1851     I32 gimme;
1852     SV **newsp;
1853     PMOP *newpm;
1854     I32 optype = 0;
1855     SV *sv;
1856
1857     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1858         if (cxstack_ix == PL_sortcxix
1859             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1860         {
1861             if (cxstack_ix > PL_sortcxix)
1862                 dounwind(PL_sortcxix);
1863             AvARRAY(PL_curstack)[1] = *SP;
1864             PL_stack_sp = PL_stack_base + 1;
1865             return 0;
1866         }
1867     }
1868
1869     cxix = dopoptosub(cxstack_ix);
1870     if (cxix < 0)
1871         DIE(aTHX_ "Can't return outside a subroutine");
1872     if (cxix < cxstack_ix)
1873         dounwind(cxix);
1874
1875     POPBLOCK(cx,newpm);
1876     switch (CxTYPE(cx)) {
1877     case CXt_SUB:
1878         popsub2 = TRUE;
1879         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1880         break;
1881     case CXt_EVAL:
1882         if (!(PL_in_eval & EVAL_KEEPERR))
1883             clear_errsv = TRUE;
1884         POPEVAL(cx);
1885         if (CxTRYBLOCK(cx))
1886             break;
1887         lex_end();
1888         if (optype == OP_REQUIRE &&
1889             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1890         {
1891             /* Unassume the success we assumed earlier. */
1892             SV *nsv = cx->blk_eval.old_namesv;
1893             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1894             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1895         }
1896         break;
1897     case CXt_FORMAT:
1898         POPFORMAT(cx);
1899         break;
1900     default:
1901         DIE(aTHX_ "panic: return");
1902     }
1903
1904     TAINT_NOT;
1905     if (gimme == G_SCALAR) {
1906         if (MARK < SP) {
1907             if (popsub2) {
1908                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1909                     if (SvTEMP(TOPs)) {
1910                         *++newsp = SvREFCNT_inc(*SP);
1911                         FREETMPS;
1912                         sv_2mortal(*newsp);
1913                     }
1914                     else {
1915                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1916                         FREETMPS;
1917                         *++newsp = sv_mortalcopy(sv);
1918                         SvREFCNT_dec(sv);
1919                     }
1920                 }
1921                 else
1922                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1923             }
1924             else
1925                 *++newsp = sv_mortalcopy(*SP);
1926         }
1927         else
1928             *++newsp = &PL_sv_undef;
1929     }
1930     else if (gimme == G_ARRAY) {
1931         while (++MARK <= SP) {
1932             *++newsp = (popsub2 && SvTEMP(*MARK))
1933                         ? *MARK : sv_mortalcopy(*MARK);
1934             TAINT_NOT;          /* Each item is independent */
1935         }
1936     }
1937     PL_stack_sp = newsp;
1938
1939     LEAVE;
1940     /* Stack values are safe: */
1941     if (popsub2) {
1942         cxstack_ix--;
1943         POPSUB(cx,sv);  /* release CV and @_ ... */
1944     }
1945     else
1946         sv = Nullsv;
1947     PL_curpm = newpm;   /* ... and pop $1 et al */
1948
1949     LEAVESUB(sv);
1950     if (clear_errsv)
1951         sv_setpv(ERRSV,"");
1952     return pop_return();
1953 }
1954
1955 PP(pp_last)
1956 {
1957     dSP;
1958     I32 cxix;
1959     register PERL_CONTEXT *cx;
1960     I32 pop2 = 0;
1961     I32 gimme;
1962     I32 optype;
1963     OP *nextop;
1964     SV **newsp;
1965     PMOP *newpm;
1966     SV **mark;
1967     SV *sv = Nullsv;
1968
1969     if (PL_op->op_flags & OPf_SPECIAL) {
1970         cxix = dopoptoloop(cxstack_ix);
1971         if (cxix < 0)
1972             DIE(aTHX_ "Can't \"last\" outside a loop block");
1973     }
1974     else {
1975         cxix = dopoptolabel(cPVOP->op_pv);
1976         if (cxix < 0)
1977             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1978     }
1979     if (cxix < cxstack_ix)
1980         dounwind(cxix);
1981
1982     POPBLOCK(cx,newpm);
1983     cxstack_ix++; /* temporarily protect top context */
1984     mark = newsp;
1985     switch (CxTYPE(cx)) {
1986     case CXt_LOOP:
1987         pop2 = CXt_LOOP;
1988         newsp = PL_stack_base + cx->blk_loop.resetsp;
1989         nextop = cx->blk_loop.last_op->op_next;
1990         break;
1991     case CXt_SUB:
1992         pop2 = CXt_SUB;
1993         nextop = pop_return();
1994         break;
1995     case CXt_EVAL:
1996         POPEVAL(cx);
1997         nextop = pop_return();
1998         break;
1999     case CXt_FORMAT:
2000         POPFORMAT(cx);
2001         nextop = pop_return();
2002         break;
2003     default:
2004         DIE(aTHX_ "panic: last");
2005     }
2006
2007     TAINT_NOT;
2008     if (gimme == G_SCALAR) {
2009         if (MARK < SP)
2010             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2011                         ? *SP : sv_mortalcopy(*SP);
2012         else
2013             *++newsp = &PL_sv_undef;
2014     }
2015     else if (gimme == G_ARRAY) {
2016         while (++MARK <= SP) {
2017             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2018                         ? *MARK : sv_mortalcopy(*MARK);
2019             TAINT_NOT;          /* Each item is independent */
2020         }
2021     }
2022     SP = newsp;
2023     PUTBACK;
2024
2025     LEAVE;
2026     cxstack_ix--;
2027     /* Stack values are safe: */
2028     switch (pop2) {
2029     case CXt_LOOP:
2030         POPLOOP(cx);    /* release loop vars ... */
2031         LEAVE;
2032         break;
2033     case CXt_SUB:
2034         POPSUB(cx,sv);  /* release CV and @_ ... */
2035         break;
2036     }
2037     PL_curpm = newpm;   /* ... and pop $1 et al */
2038
2039     LEAVESUB(sv);
2040     return nextop;
2041 }
2042
2043 PP(pp_next)
2044 {
2045     I32 cxix;
2046     register PERL_CONTEXT *cx;
2047     I32 inner;
2048
2049     if (PL_op->op_flags & OPf_SPECIAL) {
2050         cxix = dopoptoloop(cxstack_ix);
2051         if (cxix < 0)
2052             DIE(aTHX_ "Can't \"next\" outside a loop block");
2053     }
2054     else {
2055         cxix = dopoptolabel(cPVOP->op_pv);
2056         if (cxix < 0)
2057             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2058     }
2059     if (cxix < cxstack_ix)
2060         dounwind(cxix);
2061
2062     /* clear off anything above the scope we're re-entering, but
2063      * save the rest until after a possible continue block */
2064     inner = PL_scopestack_ix;
2065     TOPBLOCK(cx);
2066     if (PL_scopestack_ix < inner)
2067         leave_scope(PL_scopestack[PL_scopestack_ix]);
2068     return cx->blk_loop.next_op;
2069 }
2070
2071 PP(pp_redo)
2072 {
2073     I32 cxix;
2074     register PERL_CONTEXT *cx;
2075     I32 oldsave;
2076
2077     if (PL_op->op_flags & OPf_SPECIAL) {
2078         cxix = dopoptoloop(cxstack_ix);
2079         if (cxix < 0)
2080             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2081     }
2082     else {
2083         cxix = dopoptolabel(cPVOP->op_pv);
2084         if (cxix < 0)
2085             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2086     }
2087     if (cxix < cxstack_ix)
2088         dounwind(cxix);
2089
2090     TOPBLOCK(cx);
2091     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2092     LEAVE_SCOPE(oldsave);
2093     return cx->blk_loop.redo_op;
2094 }
2095
2096 STATIC OP *
2097 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2098 {
2099     OP *kid = Nullop;
2100     OP **ops = opstack;
2101     static char too_deep[] = "Target of goto is too deeply nested";
2102
2103     if (ops >= oplimit)
2104         Perl_croak(aTHX_ too_deep);
2105     if (o->op_type == OP_LEAVE ||
2106         o->op_type == OP_SCOPE ||
2107         o->op_type == OP_LEAVELOOP ||
2108         o->op_type == OP_LEAVESUB ||
2109         o->op_type == OP_LEAVETRY)
2110     {
2111         *ops++ = cUNOPo->op_first;
2112         if (ops >= oplimit)
2113             Perl_croak(aTHX_ too_deep);
2114     }
2115     *ops = 0;
2116     if (o->op_flags & OPf_KIDS) {
2117         /* First try all the kids at this level, since that's likeliest. */
2118         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2119             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2120                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2121                 return kid;
2122         }
2123         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2124             if (kid == PL_lastgotoprobe)
2125                 continue;
2126             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2127                 if (ops == opstack)
2128                     *ops++ = kid;
2129                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2130                          ops[-1]->op_type == OP_DBSTATE)
2131                     ops[-1] = kid;
2132                 else
2133                     *ops++ = kid;
2134             }
2135             if ((o = dofindlabel(kid, label, ops, oplimit)))
2136                 return o;
2137         }
2138     }
2139     *ops = 0;
2140     return 0;
2141 }
2142
2143 PP(pp_dump)
2144 {
2145     return pp_goto();
2146     /*NOTREACHED*/
2147 }
2148
2149 PP(pp_goto)
2150 {
2151     dSP;
2152     OP *retop = 0;
2153     I32 ix;
2154     register PERL_CONTEXT *cx;
2155 #define GOTO_DEPTH 64
2156     OP *enterops[GOTO_DEPTH];
2157     char *label;
2158     int do_dump = (PL_op->op_type == OP_DUMP);
2159     static char must_have_label[] = "goto must have label";
2160
2161     label = 0;
2162     if (PL_op->op_flags & OPf_STACKED) {
2163         SV *sv = POPs;
2164         STRLEN n_a;
2165
2166         /* This egregious kludge implements goto &subroutine */
2167         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2168             I32 cxix;
2169             register PERL_CONTEXT *cx;
2170             CV* cv = (CV*)SvRV(sv);
2171             SV** mark;
2172             I32 items = 0;
2173             I32 oldsave;
2174
2175         retry:
2176             if (!CvROOT(cv) && !CvXSUB(cv)) {
2177                 GV *gv = CvGV(cv);
2178                 GV *autogv;
2179                 if (gv) {
2180                     SV *tmpstr;
2181                     /* autoloaded stub? */
2182                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2183                         goto retry;
2184                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2185                                           GvNAMELEN(gv), FALSE);
2186                     if (autogv && (cv = GvCV(autogv)))
2187                         goto retry;
2188                     tmpstr = sv_newmortal();
2189                     gv_efullname3(tmpstr, gv, Nullch);
2190                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2191                 }
2192                 DIE(aTHX_ "Goto undefined subroutine");
2193             }
2194
2195             /* First do some returnish stuff. */
2196             SvREFCNT_inc(cv); /* avoid premature free during unwind */
2197             FREETMPS;
2198             cxix = dopoptosub(cxstack_ix);
2199             if (cxix < 0)
2200                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2201             if (cxix < cxstack_ix)
2202                 dounwind(cxix);
2203             TOPBLOCK(cx);
2204             if (CxREALEVAL(cx))
2205                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2206             mark = PL_stack_sp;
2207             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2208                 /* put @_ back onto stack */
2209                 AV* av = cx->blk_sub.argarray;
2210
2211                 items = AvFILLp(av) + 1;
2212                 PL_stack_sp++;
2213                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2214                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2215                 PL_stack_sp += items;
2216                 SvREFCNT_dec(GvAV(PL_defgv));
2217                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2218                 /* abandon @_ if it got reified */
2219                 if (AvREAL(av)) {
2220                     (void)sv_2mortal((SV*)av);  /* delay until return */
2221                     av = newAV();
2222                     av_extend(av, items-1);
2223                     AvFLAGS(av) = AVf_REIFY;
2224                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2225                 }
2226                 else
2227                     CLEAR_ARGARRAY(av);
2228             }
2229             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2230                 AV* av;
2231                 av = GvAV(PL_defgv);
2232                 items = AvFILLp(av) + 1;
2233                 PL_stack_sp++;
2234                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2235                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2236                 PL_stack_sp += items;
2237             }
2238             if (CxTYPE(cx) == CXt_SUB &&
2239                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2240                 SvREFCNT_dec(cx->blk_sub.cv);
2241             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2242             LEAVE_SCOPE(oldsave);
2243
2244             /* Now do some callish stuff. */
2245             SAVETMPS;
2246             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2247             if (CvXSUB(cv)) {
2248 #ifdef PERL_XSUB_OLDSTYLE
2249                 if (CvOLDSTYLE(cv)) {
2250                     I32 (*fp3)(int,int,int);
2251                     while (SP > mark) {
2252                         SP[1] = SP[0];
2253                         SP--;
2254                     }
2255                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2256                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2257                                    mark - PL_stack_base + 1,
2258                                    items);
2259                     SP = PL_stack_base + items;
2260                 }
2261                 else
2262 #endif /* PERL_XSUB_OLDSTYLE */
2263                 {
2264                     SV **newsp;
2265                     I32 gimme;
2266
2267                     PL_stack_sp--;              /* There is no cv arg. */
2268                     /* Push a mark for the start of arglist */
2269                     PUSHMARK(mark);
2270                     (void)(*CvXSUB(cv))(aTHX_ cv);
2271                     /* Pop the current context like a decent sub should */
2272                     POPBLOCK(cx, PL_curpm);
2273                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2274                 }
2275                 LEAVE;
2276                 return pop_return();
2277             }
2278             else {
2279                 AV* padlist = CvPADLIST(cv);
2280                 if (CxTYPE(cx) == CXt_EVAL) {
2281                     PL_in_eval = cx->blk_eval.old_in_eval;
2282                     PL_eval_root = cx->blk_eval.old_eval_root;
2283                     cx->cx_type = CXt_SUB;
2284                     cx->blk_sub.hasargs = 0;
2285                 }
2286                 cx->blk_sub.cv = cv;
2287                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2288
2289                 CvDEPTH(cv)++;
2290                 if (CvDEPTH(cv) < 2)
2291                     (void)SvREFCNT_inc(cv);
2292                 else {
2293                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2294                         sub_crush_depth(cv);
2295                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2296                 }
2297                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2298                 if (cx->blk_sub.hasargs)
2299                 {
2300                     AV* av = (AV*)PAD_SVl(0);
2301                     SV** ary;
2302
2303                     cx->blk_sub.savearray = GvAV(PL_defgv);
2304                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2305                     CX_CURPAD_SAVE(cx->blk_sub);
2306                     cx->blk_sub.argarray = av;
2307                     ++mark;
2308
2309                     if (items >= AvMAX(av) + 1) {
2310                         ary = AvALLOC(av);
2311                         if (AvARRAY(av) != ary) {
2312                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2313                             SvPVX(av) = (char*)ary;
2314                         }
2315                         if (items >= AvMAX(av) + 1) {
2316                             AvMAX(av) = items - 1;
2317                             Renew(ary,items+1,SV*);
2318                             AvALLOC(av) = ary;
2319                             SvPVX(av) = (char*)ary;
2320                         }
2321                     }
2322                     Copy(mark,AvARRAY(av),items,SV*);
2323                     AvFILLp(av) = items - 1;
2324                     assert(!AvREAL(av));
2325                     while (items--) {
2326                         if (*mark)
2327                             SvTEMP_off(*mark);
2328                         mark++;
2329                     }
2330                 }
2331                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2332                     /*
2333                      * We do not care about using sv to call CV;
2334                      * it's for informational purposes only.
2335                      */
2336                     SV *sv = GvSV(PL_DBsub);
2337                     CV *gotocv;
2338
2339                     if (PERLDB_SUB_NN) {
2340                         (void)SvUPGRADE(sv, SVt_PVIV);
2341                         (void)SvIOK_on(sv);
2342                         SAVEIV(SvIVX(sv));
2343                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2344                     } else {
2345                         save_item(sv);
2346                         gv_efullname3(sv, CvGV(cv), Nullch);
2347                     }
2348                     if (  PERLDB_GOTO
2349                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2350                         PUSHMARK( PL_stack_sp );
2351                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2352                         PL_stack_sp--;
2353                     }
2354                 }
2355                 RETURNOP(CvSTART(cv));
2356             }
2357         }
2358         else {
2359             label = SvPV(sv,n_a);
2360             if (!(do_dump || *label))
2361                 DIE(aTHX_ must_have_label);
2362         }
2363     }
2364     else if (PL_op->op_flags & OPf_SPECIAL) {
2365         if (! do_dump)
2366             DIE(aTHX_ must_have_label);
2367     }
2368     else
2369         label = cPVOP->op_pv;
2370
2371     if (label && *label) {
2372         OP *gotoprobe = 0;
2373         bool leaving_eval = FALSE;
2374         bool in_block = FALSE;
2375         PERL_CONTEXT *last_eval_cx = 0;
2376
2377         /* find label */
2378
2379         PL_lastgotoprobe = 0;
2380         *enterops = 0;
2381         for (ix = cxstack_ix; ix >= 0; ix--) {
2382             cx = &cxstack[ix];
2383             switch (CxTYPE(cx)) {
2384             case CXt_EVAL:
2385                 leaving_eval = TRUE;
2386                 if (!CxTRYBLOCK(cx)) {
2387                     gotoprobe = (last_eval_cx ?
2388                                 last_eval_cx->blk_eval.old_eval_root :
2389                                 PL_eval_root);
2390                     last_eval_cx = cx;
2391                     break;
2392                 }
2393                 /* else fall through */
2394             case CXt_LOOP:
2395                 gotoprobe = cx->blk_oldcop->op_sibling;
2396                 break;
2397             case CXt_SUBST:
2398                 continue;
2399             case CXt_BLOCK:
2400                 if (ix) {
2401                     gotoprobe = cx->blk_oldcop->op_sibling;
2402                     in_block = TRUE;
2403                 } else
2404                     gotoprobe = PL_main_root;
2405                 break;
2406             case CXt_SUB:
2407                 if (CvDEPTH(cx->blk_sub.cv)) {
2408                     gotoprobe = CvROOT(cx->blk_sub.cv);
2409                     break;
2410                 }
2411                 /* FALL THROUGH */
2412             case CXt_FORMAT:
2413             case CXt_NULL:
2414                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2415             default:
2416                 if (ix)
2417                     DIE(aTHX_ "panic: goto");
2418                 gotoprobe = PL_main_root;
2419                 break;
2420             }
2421             if (gotoprobe) {
2422                 retop = dofindlabel(gotoprobe, label,
2423                                     enterops, enterops + GOTO_DEPTH);
2424                 if (retop)
2425                     break;
2426             }
2427             PL_lastgotoprobe = gotoprobe;
2428         }
2429         if (!retop)
2430             DIE(aTHX_ "Can't find label %s", label);
2431
2432         /* if we're leaving an eval, check before we pop any frames
2433            that we're not going to punt, otherwise the error
2434            won't be caught */
2435
2436         if (leaving_eval && *enterops && enterops[1]) {
2437             I32 i;
2438             for (i = 1; enterops[i]; i++)
2439                 if (enterops[i]->op_type == OP_ENTERITER)
2440                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2441         }
2442
2443         /* pop unwanted frames */
2444
2445         if (ix < cxstack_ix) {
2446             I32 oldsave;
2447
2448             if (ix < 0)
2449                 ix = 0;
2450             dounwind(ix);
2451             TOPBLOCK(cx);
2452             oldsave = PL_scopestack[PL_scopestack_ix];
2453             LEAVE_SCOPE(oldsave);
2454         }
2455
2456         /* push wanted frames */
2457
2458         if (*enterops && enterops[1]) {
2459             OP *oldop = PL_op;
2460             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2461             for (; enterops[ix]; ix++) {
2462                 PL_op = enterops[ix];
2463                 /* Eventually we may want to stack the needed arguments
2464                  * for each op.  For now, we punt on the hard ones. */
2465                 if (PL_op->op_type == OP_ENTERITER)
2466                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2467                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2468             }
2469             PL_op = oldop;
2470         }
2471     }
2472
2473     if (do_dump) {
2474 #ifdef VMS
2475         if (!retop) retop = PL_main_start;
2476 #endif
2477         PL_restartop = retop;
2478         PL_do_undump = TRUE;
2479
2480         my_unexec();
2481
2482         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2483         PL_do_undump = FALSE;
2484     }
2485
2486     RETURNOP(retop);
2487 }
2488
2489 PP(pp_exit)
2490 {
2491     dSP;
2492     I32 anum;
2493
2494     if (MAXARG < 1)
2495         anum = 0;
2496     else {
2497         anum = SvIVx(POPs);
2498 #ifdef VMS
2499         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2500             anum = 0;
2501         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2502 #endif
2503     }
2504     PL_exit_flags |= PERL_EXIT_EXPECTED;
2505     my_exit(anum);
2506     PUSHs(&PL_sv_undef);
2507     RETURN;
2508 }
2509
2510 #ifdef NOTYET
2511 PP(pp_nswitch)
2512 {
2513     dSP;
2514     NV value = SvNVx(GvSV(cCOP->cop_gv));
2515     register I32 match = I_32(value);
2516
2517     if (value < 0.0) {
2518         if (((NV)match) > value)
2519             --match;            /* was fractional--truncate other way */
2520     }
2521     match -= cCOP->uop.scop.scop_offset;
2522     if (match < 0)
2523         match = 0;
2524     else if (match > cCOP->uop.scop.scop_max)
2525         match = cCOP->uop.scop.scop_max;
2526     PL_op = cCOP->uop.scop.scop_next[match];
2527     RETURNOP(PL_op);
2528 }
2529
2530 PP(pp_cswitch)
2531 {
2532     dSP;
2533     register I32 match;
2534
2535     if (PL_multiline)
2536         PL_op = PL_op->op_next;                 /* can't assume anything */
2537     else {
2538         STRLEN n_a;
2539         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2540         match -= cCOP->uop.scop.scop_offset;
2541         if (match < 0)
2542             match = 0;
2543         else if (match > cCOP->uop.scop.scop_max)
2544             match = cCOP->uop.scop.scop_max;
2545         PL_op = cCOP->uop.scop.scop_next[match];
2546     }
2547     RETURNOP(PL_op);
2548 }
2549 #endif
2550
2551 /* Eval. */
2552
2553 STATIC void
2554 S_save_lines(pTHX_ AV *array, SV *sv)
2555 {
2556     register char *s = SvPVX(sv);
2557     register char *send = SvPVX(sv) + SvCUR(sv);
2558     register char *t;
2559     register I32 line = 1;
2560
2561     while (s && s < send) {
2562         SV *tmpstr = NEWSV(85,0);
2563
2564         sv_upgrade(tmpstr, SVt_PVMG);
2565         t = strchr(s, '\n');
2566         if (t)
2567             t++;
2568         else
2569             t = send;
2570
2571         sv_setpvn(tmpstr, s, t - s);
2572         av_store(array, line++, tmpstr);
2573         s = t;
2574     }
2575 }
2576
2577 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2578 STATIC void *
2579 S_docatch_body(pTHX_ va_list args)
2580 {
2581     return docatch_body();
2582 }
2583 #endif
2584
2585 STATIC void *
2586 S_docatch_body(pTHX)
2587 {
2588     CALLRUNOPS(aTHX);
2589     return NULL;
2590 }
2591
2592 STATIC OP *
2593 S_docatch(pTHX_ OP *o)
2594 {
2595     int ret;
2596     OP *oldop = PL_op;
2597     OP *retop;
2598     volatile PERL_SI *cursi = PL_curstackinfo;
2599     dJMPENV;
2600
2601 #ifdef DEBUGGING
2602     assert(CATCH_GET == TRUE);
2603 #endif
2604     PL_op = o;
2605
2606     /* Normally, the leavetry at the end of this block of ops will
2607      * pop an op off the return stack and continue there. By setting
2608      * the op to Nullop, we force an exit from the inner runops()
2609      * loop. DAPM.
2610      */
2611     retop = pop_return();
2612     push_return(Nullop);
2613
2614 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2615  redo_body:
2616     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2617 #else
2618     JMPENV_PUSH(ret);
2619 #endif
2620     switch (ret) {
2621     case 0:
2622 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2623  redo_body:
2624         docatch_body();
2625 #endif
2626         break;
2627     case 3:
2628         /* die caught by an inner eval - continue inner loop */
2629         if (PL_restartop && cursi == PL_curstackinfo) {
2630             PL_op = PL_restartop;
2631             PL_restartop = 0;
2632             goto redo_body;
2633         }
2634         /* a die in this eval - continue in outer loop */
2635         if (!PL_restartop)
2636             break;
2637         /* FALL THROUGH */
2638     default:
2639         JMPENV_POP;
2640         PL_op = oldop;
2641         JMPENV_JUMP(ret);
2642         /* NOTREACHED */
2643     }
2644     JMPENV_POP;
2645     PL_op = oldop;
2646     return retop;
2647 }
2648
2649 OP *
2650 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2651 /* sv Text to convert to OP tree. */
2652 /* startop op_free() this to undo. */
2653 /* code Short string id of the caller. */
2654 {
2655     dSP;                                /* Make POPBLOCK work. */
2656     PERL_CONTEXT *cx;
2657     SV **newsp;
2658     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2659     I32 optype;
2660     OP dummy;
2661     OP *rop;
2662     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2663     char *tmpbuf = tbuf;
2664     char *safestr;
2665     int runtime;
2666     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2667
2668     ENTER;
2669     lex_start(sv);
2670     SAVETMPS;
2671     /* switch to eval mode */
2672
2673     if (IN_PERL_COMPILETIME) {
2674         SAVECOPSTASH_FREE(&PL_compiling);
2675         CopSTASH_set(&PL_compiling, PL_curstash);
2676     }
2677     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2678         SV *sv = sv_newmortal();
2679         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2680                        code, (unsigned long)++PL_evalseq,
2681                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2682         tmpbuf = SvPVX(sv);
2683     }
2684     else
2685         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2686     SAVECOPFILE_FREE(&PL_compiling);
2687     CopFILE_set(&PL_compiling, tmpbuf+2);
2688     SAVECOPLINE(&PL_compiling);
2689     CopLINE_set(&PL_compiling, 1);
2690     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2691        deleting the eval's FILEGV from the stash before gv_check() runs
2692        (i.e. before run-time proper). To work around the coredump that
2693        ensues, we always turn GvMULTI_on for any globals that were
2694        introduced within evals. See force_ident(). GSAR 96-10-12 */
2695     safestr = savepv(tmpbuf);
2696     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2697     SAVEHINTS();
2698 #ifdef OP_IN_REGISTER
2699     PL_opsave = op;
2700 #else
2701     SAVEVPTR(PL_op);
2702 #endif
2703     PL_hints &= HINT_UTF8;
2704
2705     /* we get here either during compilation, or via pp_regcomp at runtime */
2706     runtime = IN_PERL_RUNTIME;
2707     if (runtime)
2708         runcv = find_runcv(NULL);
2709
2710     PL_op = &dummy;
2711     PL_op->op_type = OP_ENTEREVAL;
2712     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2713     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2714     PUSHEVAL(cx, 0, Nullgv);
2715
2716     if (runtime)
2717         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2718     else
2719         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2720     POPBLOCK(cx,PL_curpm);
2721     POPEVAL(cx);
2722
2723     (*startop)->op_type = OP_NULL;
2724     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2725     lex_end();
2726     /* XXX DAPM do this properly one year */
2727     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2728     LEAVE;
2729     if (IN_PERL_COMPILETIME)
2730         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2731 #ifdef OP_IN_REGISTER
2732     op = PL_opsave;
2733 #endif
2734     return rop;
2735 }
2736
2737
2738 /*
2739 =for apidoc find_runcv
2740
2741 Locate the CV corresponding to the currently executing sub or eval.
2742 If db_seqp is non_null, skip CVs that are in the DB package and populate
2743 *db_seqp with the cop sequence number at the point that the DB:: code was
2744 entered. (allows debuggers to eval in the scope of the breakpoint rather
2745 than in in the scope of the debuger itself).
2746
2747 =cut
2748 */
2749
2750 CV*
2751 Perl_find_runcv(pTHX_ U32 *db_seqp)
2752 {
2753     I32          ix;
2754     PERL_SI      *si;
2755     PERL_CONTEXT *cx;
2756
2757     if (db_seqp)
2758         *db_seqp = PL_curcop->cop_seq;
2759     for (si = PL_curstackinfo; si; si = si->si_prev) {
2760         for (ix = si->si_cxix; ix >= 0; ix--) {
2761             cx = &(si->si_cxstack[ix]);
2762             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2763                 CV *cv = cx->blk_sub.cv;
2764                 /* skip DB:: code */
2765                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2766                     *db_seqp = cx->blk_oldcop->cop_seq;
2767                     continue;
2768                 }
2769                 return cv;
2770             }
2771             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2772                 return PL_compcv;
2773         }
2774     }
2775     return PL_main_cv;
2776 }
2777
2778
2779 /* Compile a require/do, an eval '', or a /(?{...})/.
2780  * In the last case, startop is non-null, and contains the address of
2781  * a pointer that should be set to the just-compiled code.
2782  * outside is the lexically enclosing CV (if any) that invoked us.
2783  */
2784
2785 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2786 STATIC OP *
2787 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2788 {
2789     dSP;
2790     OP *saveop = PL_op;
2791
2792     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2793                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2794                   : EVAL_INEVAL);
2795
2796     PUSHMARK(SP);
2797
2798     SAVESPTR(PL_compcv);
2799     PL_compcv = (CV*)NEWSV(1104,0);
2800     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2801     CvEVAL_on(PL_compcv);
2802     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2803     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2804
2805     CvOUTSIDE_SEQ(PL_compcv) = seq;
2806     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2807
2808     /* set up a scratch pad */
2809
2810     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2811
2812
2813     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2814
2815     /* make sure we compile in the right package */
2816
2817     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2818         SAVESPTR(PL_curstash);
2819         PL_curstash = CopSTASH(PL_curcop);
2820     }
2821     SAVESPTR(PL_beginav);
2822     PL_beginav = newAV();
2823     SAVEFREESV(PL_beginav);
2824     SAVEI32(PL_error_count);
2825
2826     /* try to compile it */
2827
2828     PL_eval_root = Nullop;
2829     PL_error_count = 0;
2830     PL_curcop = &PL_compiling;
2831     PL_curcop->cop_arybase = 0;
2832     if (saveop && saveop->op_flags & OPf_SPECIAL)
2833         PL_in_eval |= EVAL_KEEPERR;
2834     else
2835         sv_setpv(ERRSV,"");
2836     if (yyparse() || PL_error_count || !PL_eval_root) {
2837         SV **newsp;                     /* Used by POPBLOCK. */
2838        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2839         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2840         STRLEN n_a;
2841
2842         PL_op = saveop;
2843         if (PL_eval_root) {
2844             op_free(PL_eval_root);
2845             PL_eval_root = Nullop;
2846         }
2847         SP = PL_stack_base + POPMARK;           /* pop original mark */
2848         if (!startop) {
2849             POPBLOCK(cx,PL_curpm);
2850             POPEVAL(cx);
2851             pop_return();
2852         }
2853         lex_end();
2854         LEAVE;
2855         if (optype == OP_REQUIRE) {
2856             char* msg = SvPVx(ERRSV, n_a);
2857            SV *nsv = cx->blk_eval.old_namesv;
2858            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2859                           &PL_sv_undef, 0);
2860             DIE(aTHX_ "%sCompilation failed in require",
2861                 *msg ? msg : "Unknown error\n");
2862         }
2863         else if (startop) {
2864             char* msg = SvPVx(ERRSV, n_a);
2865
2866             POPBLOCK(cx,PL_curpm);
2867             POPEVAL(cx);
2868             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2869                        (*msg ? msg : "Unknown error\n"));
2870         }
2871         else {
2872             char* msg = SvPVx(ERRSV, n_a);
2873             if (!*msg) {
2874                 sv_setpv(ERRSV, "Compilation error");
2875             }
2876         }
2877         RETPUSHUNDEF;
2878     }
2879     CopLINE_set(&PL_compiling, 0);
2880     if (startop) {
2881         *startop = PL_eval_root;
2882     } else
2883         SAVEFREEOP(PL_eval_root);
2884
2885     /* Set the context for this new optree.
2886      * If the last op is an OP_REQUIRE, force scalar context.
2887      * Otherwise, propagate the context from the eval(). */
2888     if (PL_eval_root->op_type == OP_LEAVEEVAL
2889             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2890             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2891             == OP_REQUIRE)
2892         scalar(PL_eval_root);
2893     else if (gimme & G_VOID)
2894         scalarvoid(PL_eval_root);
2895     else if (gimme & G_ARRAY)
2896         list(PL_eval_root);
2897     else
2898         scalar(PL_eval_root);
2899
2900     DEBUG_x(dump_eval());
2901
2902     /* Register with debugger: */
2903     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2904         CV *cv = get_cv("DB::postponed", FALSE);
2905         if (cv) {
2906             dSP;
2907             PUSHMARK(SP);
2908             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2909             PUTBACK;
2910             call_sv((SV*)cv, G_DISCARD);
2911         }
2912     }
2913
2914     /* compiled okay, so do it */
2915
2916     CvDEPTH(PL_compcv) = 1;
2917     SP = PL_stack_base + POPMARK;               /* pop original mark */
2918     PL_op = saveop;                     /* The caller may need it. */
2919     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2920
2921     RETURNOP(PL_eval_start);
2922 }
2923
2924 STATIC PerlIO *
2925 S_doopen_pm(pTHX_ const char *name, const char *mode)
2926 {
2927 #ifndef PERL_DISABLE_PMC
2928     STRLEN namelen = strlen(name);
2929     PerlIO *fp;
2930
2931     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2932         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2933         char *pmc = SvPV_nolen(pmcsv);
2934         Stat_t pmstat;
2935         Stat_t pmcstat;
2936         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2937             fp = PerlIO_open(name, mode);
2938         }
2939         else {
2940             if (PerlLIO_stat(name, &pmstat) < 0 ||
2941                 pmstat.st_mtime < pmcstat.st_mtime)
2942             {
2943                 fp = PerlIO_open(pmc, mode);
2944             }
2945             else {
2946                 fp = PerlIO_open(name, mode);
2947             }
2948         }
2949         SvREFCNT_dec(pmcsv);
2950     }
2951     else {
2952         fp = PerlIO_open(name, mode);
2953     }
2954     return fp;
2955 #else
2956     return PerlIO_open(name, mode);
2957 #endif /* !PERL_DISABLE_PMC */
2958 }
2959
2960 PP(pp_require)
2961 {
2962     dSP;
2963     register PERL_CONTEXT *cx;
2964     SV *sv;
2965     char *name;
2966     STRLEN len;
2967     char *tryname = Nullch;
2968     SV *namesv = Nullsv;
2969     SV** svp;
2970     I32 gimme = GIMME_V;
2971     PerlIO *tryrsfp = 0;
2972     STRLEN n_a;
2973     int filter_has_file = 0;
2974     GV *filter_child_proc = 0;
2975     SV *filter_state = 0;
2976     SV *filter_sub = 0;
2977     SV *hook_sv = 0;
2978     SV *encoding;
2979     OP *op;
2980
2981     sv = POPs;
2982     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2983         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2984             UV rev = 0, ver = 0, sver = 0;
2985             STRLEN len;
2986             U8 *s = (U8*)SvPVX(sv);
2987             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2988             if (s < end) {
2989                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2990                 s += len;
2991                 if (s < end) {
2992                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2993                     s += len;
2994                     if (s < end)
2995                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2996                 }
2997             }
2998             if (PERL_REVISION < rev
2999                 || (PERL_REVISION == rev
3000                     && (PERL_VERSION < ver
3001                         || (PERL_VERSION == ver
3002                             && PERL_SUBVERSION < sver))))
3003             {
3004                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3005                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3006                     PERL_VERSION, PERL_SUBVERSION);
3007             }
3008             if (ckWARN(WARN_PORTABLE))
3009                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3010                         "v-string in use/require non-portable");
3011             RETPUSHYES;
3012         }
3013         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3014             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3015                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3016                 + 0.00000099 < SvNV(sv))
3017             {
3018                 NV nrev = SvNV(sv);
3019                 UV rev = (UV)nrev;
3020                 NV nver = (nrev - rev) * 1000;
3021                 UV ver = (UV)(nver + 0.0009);
3022                 NV nsver = (nver - ver) * 1000;
3023                 UV sver = (UV)(nsver + 0.0009);
3024
3025                 /* help out with the "use 5.6" confusion */
3026                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3027                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3028                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3029                         "this is only v%d.%d.%d, stopped",
3030                         rev, ver, sver, rev, ver/100,
3031                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3032                 }
3033                 else {
3034                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3035                         "this is only v%d.%d.%d, stopped",
3036                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3037                         PERL_SUBVERSION);
3038                 }
3039             }
3040             RETPUSHYES;
3041         }
3042     }
3043     name = SvPV(sv, len);
3044     if (!(name && len > 0 && *name))
3045         DIE(aTHX_ "Null filename used");
3046     TAINT_PROPER("require");
3047     if (PL_op->op_type == OP_REQUIRE &&
3048        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3049        if (*svp != &PL_sv_undef)
3050            RETPUSHYES;
3051        else
3052            DIE(aTHX_ "Compilation failed in require");
3053     }
3054
3055     /* prepare to compile file */
3056
3057     if (path_is_absolute(name)) {
3058         tryname = name;
3059         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3060     }
3061 #ifdef MACOS_TRADITIONAL
3062     if (!tryrsfp) {
3063         char newname[256];
3064
3065         MacPerl_CanonDir(name, newname, 1);
3066         if (path_is_absolute(newname)) {
3067             tryname = newname;
3068             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3069         }
3070     }
3071 #endif
3072     if (!tryrsfp) {
3073         AV *ar = GvAVn(PL_incgv);
3074         I32 i;
3075 #ifdef VMS
3076         char *unixname;
3077         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3078 #endif
3079         {
3080             namesv = NEWSV(806, 0);
3081             for (i = 0; i <= AvFILL(ar); i++) {
3082                 SV *dirsv = *av_fetch(ar, i, TRUE);
3083
3084                 if (SvROK(dirsv)) {
3085                     int count;
3086                     SV *loader = dirsv;
3087
3088                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3089                         && !sv_isobject(loader))
3090                     {
3091                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3092                     }
3093
3094                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3095                                    PTR2UV(SvRV(dirsv)), name);
3096                     tryname = SvPVX(namesv);
3097                     tryrsfp = 0;
3098
3099                     ENTER;
3100                     SAVETMPS;
3101                     EXTEND(SP, 2);
3102
3103                     PUSHMARK(SP);
3104                     PUSHs(dirsv);
3105                     PUSHs(sv);
3106                     PUTBACK;
3107                     if (sv_isobject(loader))
3108                         count = call_method("INC", G_ARRAY);
3109                     else
3110                         count = call_sv(loader, G_ARRAY);
3111                     SPAGAIN;
3112
3113                     if (count > 0) {
3114                         int i = 0;
3115                         SV *arg;
3116
3117                         SP -= count - 1;
3118                         arg = SP[i++];
3119
3120                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3121                             arg = SvRV(arg);
3122                         }
3123
3124                         if (SvTYPE(arg) == SVt_PVGV) {
3125                             IO *io = GvIO((GV *)arg);
3126
3127                             ++filter_has_file;
3128
3129                             if (io) {
3130                                 tryrsfp = IoIFP(io);
3131                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3132                                     /* reading from a child process doesn't
3133                                        nest -- when returning from reading
3134                                        the inner module, the outer one is
3135                                        unreadable (closed?)  I've tried to
3136                                        save the gv to manage the lifespan of
3137                                        the pipe, but this didn't help. XXX */
3138                                     filter_child_proc = (GV *)arg;
3139                                     (void)SvREFCNT_inc(filter_child_proc);
3140                                 }
3141                                 else {
3142                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3143                                         PerlIO_close(IoOFP(io));
3144                                     }
3145                                     IoIFP(io) = Nullfp;
3146                                     IoOFP(io) = Nullfp;
3147                                 }
3148                             }
3149
3150                             if (i < count) {
3151                                 arg = SP[i++];
3152                             }
3153                         }
3154
3155                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3156                             filter_sub = arg;
3157                             (void)SvREFCNT_inc(filter_sub);
3158
3159                             if (i < count) {
3160                                 filter_state = SP[i];
3161                                 (void)SvREFCNT_inc(filter_state);
3162                             }
3163
3164                             if (tryrsfp == 0) {
3165                                 tryrsfp = PerlIO_open("/dev/null",
3166                                                       PERL_SCRIPT_MODE);
3167                             }
3168                         }
3169                         SP--;
3170                     }
3171
3172                     PUTBACK;
3173                     FREETMPS;
3174                     LEAVE;
3175
3176                     if (tryrsfp) {
3177                         hook_sv = dirsv;
3178                         break;
3179                     }
3180
3181                     filter_has_file = 0;
3182                     if (filter_child_proc) {
3183                         SvREFCNT_dec(filter_child_proc);
3184                         filter_child_proc = 0;
3185                     }
3186                     if (filter_state) {
3187                         SvREFCNT_dec(filter_state);
3188                         filter_state = 0;
3189                     }
3190                     if (filter_sub) {
3191                         SvREFCNT_dec(filter_sub);
3192                         filter_sub = 0;
3193                     }
3194                 }
3195                 else {
3196                   if (!path_is_absolute(name)
3197 #ifdef MACOS_TRADITIONAL
3198                         /* We consider paths of the form :a:b ambiguous and interpret them first
3199                            as global then as local
3200                         */
3201                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3202 #endif
3203                   ) {
3204                     char *dir = SvPVx(dirsv, n_a);
3205 #ifdef MACOS_TRADITIONAL
3206                     char buf1[256];
3207                     char buf2[256];
3208
3209                     MacPerl_CanonDir(name, buf2, 1);
3210                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3211 #else
3212 #ifdef VMS
3213                     char *unixdir;
3214                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3215                         continue;
3216                     sv_setpv(namesv, unixdir);
3217                     sv_catpv(namesv, unixname);
3218 #else
3219                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3220 #endif
3221 #endif
3222                     TAINT_PROPER("require");
3223                     tryname = SvPVX(namesv);
3224                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3225                     if (tryrsfp) {
3226                         if (tryname[0] == '.' && tryname[1] == '/')
3227                             tryname += 2;
3228                         break;
3229                     }
3230                   }
3231                 }
3232             }
3233         }
3234     }
3235     SAVECOPFILE_FREE(&PL_compiling);
3236     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3237     SvREFCNT_dec(namesv);
3238     if (!tryrsfp) {
3239         if (PL_op->op_type == OP_REQUIRE) {
3240             char *msgstr = name;
3241             if (namesv) {                       /* did we lookup @INC? */
3242                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3243                 SV *dirmsgsv = NEWSV(0, 0);
3244                 AV *ar = GvAVn(PL_incgv);
3245                 I32 i;
3246                 sv_catpvn(msg, " in @INC", 8);
3247                 if (instr(SvPVX(msg), ".h "))
3248                     sv_catpv(msg, " (change .h to .ph maybe?)");
3249                 if (instr(SvPVX(msg), ".ph "))
3250                     sv_catpv(msg, " (did you run h2ph?)");
3251                 sv_catpv(msg, " (@INC contains:");
3252                 for (i = 0; i <= AvFILL(ar); i++) {
3253                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3254                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3255                     sv_catsv(msg, dirmsgsv);
3256                 }
3257                 sv_catpvn(msg, ")", 1);
3258                 SvREFCNT_dec(dirmsgsv);
3259                 msgstr = SvPV_nolen(msg);
3260             }
3261             DIE(aTHX_ "Can't locate %s", msgstr);
3262         }
3263
3264         RETPUSHUNDEF;
3265     }
3266     else
3267         SETERRNO(0, SS_NORMAL);
3268
3269     /* Assume success here to prevent recursive requirement. */
3270     len = strlen(name);
3271     /* Check whether a hook in @INC has already filled %INC */
3272     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3273         (void)hv_store(GvHVn(PL_incgv), name, len,
3274                        (hook_sv ? SvREFCNT_inc(hook_sv)
3275                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3276                        0 );
3277     }
3278
3279     ENTER;
3280     SAVETMPS;
3281     lex_start(sv_2mortal(newSVpvn("",0)));
3282     SAVEGENERICSV(PL_rsfp_filters);
3283     PL_rsfp_filters = Nullav;
3284
3285     PL_rsfp = tryrsfp;
3286     SAVEHINTS();
3287     PL_hints = 0;
3288     SAVESPTR(PL_compiling.cop_warnings);
3289     if (PL_dowarn & G_WARN_ALL_ON)
3290         PL_compiling.cop_warnings = pWARN_ALL ;
3291     else if (PL_dowarn & G_WARN_ALL_OFF)
3292         PL_compiling.cop_warnings = pWARN_NONE ;
3293     else if (PL_taint_warn)
3294         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3295     else
3296         PL_compiling.cop_warnings = pWARN_STD ;
3297     SAVESPTR(PL_compiling.cop_io);
3298     PL_compiling.cop_io = Nullsv;
3299
3300     if (filter_sub || filter_child_proc) {
3301         SV *datasv = filter_add(run_user_filter, Nullsv);
3302         IoLINES(datasv) = filter_has_file;
3303         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3304         IoTOP_GV(datasv) = (GV *)filter_state;
3305         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3306     }
3307
3308     /* switch to eval mode */
3309     push_return(PL_op->op_next);
3310     PUSHBLOCK(cx, CXt_EVAL, SP);
3311     PUSHEVAL(cx, name, Nullgv);
3312
3313     SAVECOPLINE(&PL_compiling);
3314     CopLINE_set(&PL_compiling, 0);
3315
3316     PUTBACK;
3317
3318     /* Store and reset encoding. */
3319     encoding = PL_encoding;
3320     PL_encoding = Nullsv;
3321
3322     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3323
3324     /* Restore encoding. */
3325     PL_encoding = encoding;
3326
3327     return op;
3328 }
3329
3330 PP(pp_dofile)
3331 {
3332     return pp_require();
3333 }
3334
3335 PP(pp_entereval)
3336 {
3337     dSP;
3338     register PERL_CONTEXT *cx;
3339     dPOPss;
3340     I32 gimme = GIMME_V, was = PL_sub_generation;
3341     char tbuf[TYPE_DIGITS(long) + 12];
3342     char *tmpbuf = tbuf;
3343     char *safestr;
3344     STRLEN len;
3345     OP *ret;
3346     CV* runcv;
3347     U32 seq;
3348
3349     if (!SvPV(sv,len))
3350         RETPUSHUNDEF;
3351     TAINT_PROPER("eval");
3352
3353     ENTER;
3354     lex_start(sv);
3355     SAVETMPS;
3356
3357     /* switch to eval mode */
3358
3359     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3360         SV *sv = sv_newmortal();
3361         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3362                        (unsigned long)++PL_evalseq,
3363                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3364         tmpbuf = SvPVX(sv);
3365     }
3366     else
3367         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3368     SAVECOPFILE_FREE(&PL_compiling);
3369     CopFILE_set(&PL_compiling, tmpbuf+2);
3370     SAVECOPLINE(&PL_compiling);
3371     CopLINE_set(&PL_compiling, 1);
3372     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3373        deleting the eval's FILEGV from the stash before gv_check() runs
3374        (i.e. before run-time proper). To work around the coredump that
3375        ensues, we always turn GvMULTI_on for any globals that were
3376        introduced within evals. See force_ident(). GSAR 96-10-12 */
3377     safestr = savepv(tmpbuf);
3378     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3379     SAVEHINTS();
3380     PL_hints = PL_op->op_targ;
3381     SAVESPTR(PL_compiling.cop_warnings);
3382     if (specialWARN(PL_curcop->cop_warnings))
3383         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3384     else {
3385         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3386         SAVEFREESV(PL_compiling.cop_warnings);
3387     }
3388     SAVESPTR(PL_compiling.cop_io);
3389     if (specialCopIO(PL_curcop->cop_io))
3390         PL_compiling.cop_io = PL_curcop->cop_io;
3391     else {
3392         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3393         SAVEFREESV(PL_compiling.cop_io);
3394     }
3395     /* special case: an eval '' executed within the DB package gets lexically
3396      * placed in the first non-DB CV rather than the current CV - this
3397      * allows the debugger to execute code, find lexicals etc, in the
3398      * scope of the code being debugged. Passing &seq gets find_runcv
3399      * to do the dirty work for us */
3400     runcv = find_runcv(&seq);
3401
3402     push_return(PL_op->op_next);
3403     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3404     PUSHEVAL(cx, 0, Nullgv);
3405
3406     /* prepare to compile string */
3407
3408     if (PERLDB_LINE && PL_curstash != PL_debstash)
3409         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3410     PUTBACK;
3411     ret = doeval(gimme, NULL, runcv, seq);
3412     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3413         && ret != PL_op->op_next) {     /* Successive compilation. */
3414         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3415     }
3416     return DOCATCH(ret);
3417 }
3418
3419 PP(pp_leaveeval)
3420 {
3421     dSP;
3422     register SV **mark;
3423     SV **newsp;
3424     PMOP *newpm;
3425     I32 gimme;
3426     register PERL_CONTEXT *cx;
3427     OP *retop;
3428     U8 save_flags = PL_op -> op_flags;
3429     I32 optype;
3430
3431     POPBLOCK(cx,newpm);
3432     POPEVAL(cx);
3433     retop = pop_return();
3434
3435     TAINT_NOT;
3436     if (gimme == G_VOID)
3437         MARK = newsp;
3438     else if (gimme == G_SCALAR) {
3439         MARK = newsp + 1;
3440         if (MARK <= SP) {
3441             if (SvFLAGS(TOPs) & SVs_TEMP)
3442                 *MARK = TOPs;
3443             else
3444                 *MARK = sv_mortalcopy(TOPs);
3445         }
3446         else {
3447             MEXTEND(mark,0);
3448             *MARK = &PL_sv_undef;
3449         }
3450         SP = MARK;
3451     }
3452     else {
3453         /* in case LEAVE wipes old return values */
3454         for (mark = newsp + 1; mark <= SP; mark++) {
3455             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3456                 *mark = sv_mortalcopy(*mark);
3457                 TAINT_NOT;      /* Each item is independent */
3458             }
3459         }
3460     }
3461     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3462
3463 #ifdef DEBUGGING
3464     assert(CvDEPTH(PL_compcv) == 1);
3465 #endif
3466     CvDEPTH(PL_compcv) = 0;
3467     lex_end();
3468
3469     if (optype == OP_REQUIRE &&
3470         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3471     {
3472         /* Unassume the success we assumed earlier. */
3473         SV *nsv = cx->blk_eval.old_namesv;
3474         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3475         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3476         /* die_where() did LEAVE, or we won't be here */
3477     }
3478     else {
3479         LEAVE;
3480         if (!(save_flags & OPf_SPECIAL))
3481             sv_setpv(ERRSV,"");
3482     }
3483
3484     RETURNOP(retop);
3485 }
3486
3487 PP(pp_entertry)
3488 {
3489     dSP;
3490     register PERL_CONTEXT *cx;
3491     I32 gimme = GIMME_V;
3492
3493     ENTER;
3494     SAVETMPS;
3495
3496     push_return(cLOGOP->op_other->op_next);
3497     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3498     PUSHEVAL(cx, 0, 0);
3499
3500     PL_in_eval = EVAL_INEVAL;
3501     sv_setpv(ERRSV,"");
3502     PUTBACK;
3503     return DOCATCH(PL_op->op_next);
3504 }
3505
3506 PP(pp_leavetry)
3507 {
3508     dSP;
3509     register SV **mark;
3510     SV **newsp;
3511     PMOP *newpm;
3512     OP* retop;
3513     I32 gimme;
3514     register PERL_CONTEXT *cx;
3515     I32 optype;
3516
3517     POPBLOCK(cx,newpm);
3518     POPEVAL(cx);
3519     retop = pop_return();
3520
3521     TAINT_NOT;
3522     if (gimme == G_VOID)
3523         SP = newsp;
3524     else if (gimme == G_SCALAR) {
3525         MARK = newsp + 1;
3526         if (MARK <= SP) {
3527             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3528                 *MARK = TOPs;
3529             else
3530                 *MARK = sv_mortalcopy(TOPs);
3531         }
3532         else {
3533             MEXTEND(mark,0);
3534             *MARK = &PL_sv_undef;
3535         }
3536         SP = MARK;
3537     }
3538     else {
3539         /* in case LEAVE wipes old return values */
3540         for (mark = newsp + 1; mark <= SP; mark++) {
3541             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3542                 *mark = sv_mortalcopy(*mark);
3543                 TAINT_NOT;      /* Each item is independent */
3544             }
3545         }
3546     }
3547     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3548
3549     LEAVE;
3550     sv_setpv(ERRSV,"");
3551     RETURNOP(retop);
3552 }
3553
3554 STATIC OP *
3555 S_doparseform(pTHX_ SV *sv)
3556 {
3557     STRLEN len;
3558     register char *s = SvPV_force(sv, len);
3559     register char *send = s + len;
3560     register char *base = Nullch;
3561     register I32 skipspaces = 0;
3562     bool noblank   = FALSE;
3563     bool repeat    = FALSE;
3564     bool postspace = FALSE;
3565     U32 *fops;
3566     register U32 *fpc;
3567     U32 *linepc = 0;
3568     register I32 arg;
3569     bool ischop;
3570     bool unchopnum = FALSE;
3571     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3572
3573     if (len == 0)
3574         Perl_croak(aTHX_ "Null picture in formline");
3575
3576     /* estimate the buffer size needed */
3577     for (base = s; s <= send; s++) {
3578         if (*s == '\n' || *s == '@' || *s == '^')
3579             maxops += 10;
3580     }
3581     s = base;
3582     base = Nullch;
3583
3584     New(804, fops, maxops, U32);
3585     fpc = fops;
3586
3587     if (s < send) {
3588         linepc = fpc;
3589         *fpc++ = FF_LINEMARK;
3590         noblank = repeat = FALSE;
3591         base = s;
3592     }
3593
3594     while (s <= send) {
3595         switch (*s++) {
3596         default:
3597             skipspaces = 0;
3598             continue;
3599
3600         case '~':
3601             if (*s == '~') {
3602                 repeat = TRUE;
3603                 *s = ' ';
3604             }
3605             noblank = TRUE;
3606             s[-1] = ' ';
3607             /* FALL THROUGH */
3608         case ' ': case '\t':
3609             skipspaces++;
3610             continue;
3611         case 0:
3612             if (s < send) {
3613                 skipspaces = 0;
3614                 continue;
3615             } /* else FALL THROUGH */
3616         case '\n':
3617             arg = s - base;
3618             skipspaces++;
3619             arg -= skipspaces;
3620             if (arg) {
3621                 if (postspace)
3622                     *fpc++ = FF_SPACE;
3623                 *fpc++ = FF_LITERAL;
3624                 *fpc++ = (U16)arg;
3625             }
3626             postspace = FALSE;
3627             if (s <= send)
3628                 skipspaces--;
3629             if (skipspaces) {
3630                 *fpc++ = FF_SKIP;
3631                 *fpc++ = (U16)skipspaces;
3632             }
3633             skipspaces = 0;
3634             if (s <= send)
3635                 *fpc++ = FF_NEWLINE;
3636             if (noblank) {
3637                 *fpc++ = FF_BLANK;
3638                 if (repeat)
3639                     arg = fpc - linepc + 1;
3640                 else
3641                     arg = 0;
3642                 *fpc++ = (U16)arg;
3643             }
3644             if (s < send) {
3645                 linepc = fpc;
3646                 *fpc++ = FF_LINEMARK;
3647                 noblank = repeat = FALSE;
3648                 base = s;
3649             }
3650             else
3651                 s++;
3652             continue;
3653
3654         case '@':
3655         case '^':
3656             ischop = s[-1] == '^';
3657
3658             if (postspace) {
3659                 *fpc++ = FF_SPACE;
3660                 postspace = FALSE;
3661             }
3662             arg = (s - base) - 1;
3663             if (arg) {
3664                 *fpc++ = FF_LITERAL;
3665                 *fpc++ = (U16)arg;
3666             }
3667
3668             base = s - 1;
3669             *fpc++ = FF_FETCH;
3670             if (*s == '*') {
3671                 s++;
3672                 *fpc++ = 2;  /* skip the @* or ^* */
3673                 if (ischop) {
3674                     *fpc++ = FF_LINESNGL;
3675                     *fpc++ = FF_CHOP;
3676                 } else
3677                     *fpc++ = FF_LINEGLOB;
3678             }
3679             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3680                 arg = ischop ? 512 : 0;
3681                 base = s - 1;
3682                 while (*s == '#')
3683                     s++;
3684                 if (*s == '.') {
3685                     char *f;
3686                     s++;
3687                     f = s;
3688                     while (*s == '#')
3689                         s++;
3690                     arg |= 256 + (s - f);
3691                 }
3692                 *fpc++ = s - base;              /* fieldsize for FETCH */
3693                 *fpc++ = FF_DECIMAL;
3694                 *fpc++ = (U16)arg;
3695                 unchopnum |= ! ischop;
3696             }
3697             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3698                 arg = ischop ? 512 : 0;
3699                 base = s - 1;
3700                 s++;                                /* skip the '0' first */
3701                 while (*s == '#')
3702                     s++;
3703                 if (*s == '.') {
3704                     char *f;
3705                     s++;
3706                     f = s;
3707                     while (*s == '#')
3708                         s++;
3709                     arg |= 256 + (s - f);
3710                 }
3711                 *fpc++ = s - base;                /* fieldsize for FETCH */
3712                 *fpc++ = FF_0DECIMAL;
3713                 *fpc++ = (U16)arg;
3714                 unchopnum |= ! ischop;
3715             }
3716             else {
3717                 I32 prespace = 0;
3718                 bool ismore = FALSE;
3719
3720                 if (*s == '>') {
3721                     while (*++s == '>') ;
3722                     prespace = FF_SPACE;
3723                 }
3724                 else if (*s == '|') {
3725                     while (*++s == '|') ;
3726                     prespace = FF_HALFSPACE;
3727                     postspace = TRUE;
3728                 }
3729                 else {
3730                     if (*s == '<')
3731                         while (*++s == '<') ;
3732                     postspace = TRUE;
3733                 }
3734                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3735                     s += 3;
3736                     ismore = TRUE;
3737                 }
3738                 *fpc++ = s - base;              /* fieldsize for FETCH */
3739
3740                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3741
3742                 if (prespace)
3743                     *fpc++ = (U16)prespace;
3744                 *fpc++ = FF_ITEM;
3745                 if (ismore)
3746                     *fpc++ = FF_MORE;
3747                 if (ischop)
3748                     *fpc++ = FF_CHOP;
3749             }
3750             base = s;
3751             skipspaces = 0;
3752             continue;
3753         }
3754     }
3755     *fpc++ = FF_END;
3756
3757     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3758     arg = fpc - fops;
3759     { /* need to jump to the next word */
3760         int z;
3761         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3762         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3763         s = SvPVX(sv) + SvCUR(sv) + z;
3764     }
3765     Copy(fops, s, arg, U32);
3766     Safefree(fops);
3767     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3768     SvCOMPILED_on(sv);
3769
3770     if (unchopnum && repeat)
3771         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3772     return 0;
3773 }
3774
3775
3776 STATIC bool
3777 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3778 {
3779     /* Can value be printed in fldsize chars, using %*.*f ? */
3780     NV pwr = 1;
3781     NV eps = 0.5;
3782     bool res = FALSE;
3783     int intsize = fldsize - (value < 0 ? 1 : 0);
3784
3785     if (frcsize & 256)
3786         intsize--;
3787     frcsize &= 255;
3788     intsize -= frcsize;
3789
3790     while (intsize--) pwr *= 10.0;
3791     while (frcsize--) eps /= 10.0;
3792
3793     if( value >= 0 ){
3794         if (value + eps >= pwr)
3795             res = TRUE;
3796     } else {
3797         if (value - eps <= -pwr)
3798             res = TRUE;
3799     }
3800     return res;
3801 }
3802
3803 static I32
3804 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3805 {
3806     SV *datasv = FILTER_DATA(idx);
3807     int filter_has_file = IoLINES(datasv);
3808     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3809     SV *filter_state = (SV *)IoTOP_GV(datasv);
3810     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3811     int len = 0;
3812
3813     /* I was having segfault trouble under Linux 2.2.5 after a
3814        parse error occured.  (Had to hack around it with a test
3815        for PL_error_count == 0.)  Solaris doesn't segfault --
3816        not sure where the trouble is yet.  XXX */
3817
3818     if (filter_has_file) {
3819         len = FILTER_READ(idx+1, buf_sv, maxlen);
3820     }
3821
3822     if (filter_sub && len >= 0) {
3823         dSP;
3824         int count;
3825
3826         ENTER;
3827         SAVE_DEFSV;
3828         SAVETMPS;
3829         EXTEND(SP, 2);
3830
3831         DEFSV = buf_sv;
3832         PUSHMARK(SP);
3833         PUSHs(sv_2mortal(newSViv(maxlen)));
3834         if (filter_state) {
3835             PUSHs(filter_state);
3836         }
3837         PUTBACK;
3838         count = call_sv(filter_sub, G_SCALAR);
3839         SPAGAIN;
3840
3841         if (count > 0) {
3842             SV *out = POPs;
3843             if (SvOK(out)) {
3844                 len = SvIV(out);
3845             }
3846         }
3847
3848         PUTBACK;
3849         FREETMPS;
3850         LEAVE;
3851     }
3852
3853     if (len <= 0) {
3854         IoLINES(datasv) = 0;
3855         if (filter_child_proc) {
3856             SvREFCNT_dec(filter_child_proc);
3857             IoFMT_GV(datasv) = Nullgv;
3858         }
3859         if (filter_state) {
3860             SvREFCNT_dec(filter_state);
3861             IoTOP_GV(datasv) = Nullgv;
3862         }
3863         if (filter_sub) {
3864             SvREFCNT_dec(filter_sub);
3865             IoBOTTOM_GV(datasv) = Nullgv;
3866         }
3867         filter_del(run_user_filter);
3868     }
3869
3870     return len;
3871 }
3872
3873 /* perhaps someone can come up with a better name for
3874    this?  it is not really "absolute", per se ... */
3875 static bool
3876 S_path_is_absolute(pTHX_ char *name)
3877 {
3878     if (PERL_FILE_IS_ABSOLUTE(name)
3879 #ifdef MACOS_TRADITIONAL
3880         || (*name == ':'))
3881 #else
3882         || (*name == '.' && (name[1] == '/' ||
3883                              (name[1] == '.' && name[2] == '/'))))
3884 #endif
3885     {
3886         return TRUE;
3887     }
3888     else
3889         return FALSE;
3890 }