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