pp_ctl.c

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