pp_ctl.c

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