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