pp_ctl.c

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