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                 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         (looks_like_number(left) && SvPOKp(left) && *SvPVX(left) != '0' && \
1062          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                 cx->blk_loop.iterlval = newSVsv(sv);
1802         }
1803     }
1804     else {
1805         cx->blk_loop.iterary = PL_curstack;
1806         AvFILLp(PL_curstack) = SP - PL_stack_base;
1807         cx->blk_loop.iterix = MARK - PL_stack_base;
1808     }
1809
1810     RETURN;
1811 }
1812
1813 PP(pp_enterloop)
1814 {
1815     dSP;
1816     register PERL_CONTEXT *cx;
1817     I32 gimme = GIMME_V;
1818
1819     ENTER;
1820     SAVETMPS;
1821     ENTER;
1822
1823     PUSHBLOCK(cx, CXt_LOOP, SP);
1824     PUSHLOOP(cx, 0, SP);
1825
1826     RETURN;
1827 }
1828
1829 PP(pp_leaveloop)
1830 {
1831     dSP;
1832     register PERL_CONTEXT *cx;
1833     I32 gimme;
1834     SV **newsp;
1835     PMOP *newpm;
1836     SV **mark;
1837
1838     POPBLOCK(cx,newpm);
1839     mark = newsp;
1840     newsp = PL_stack_base + cx->blk_loop.resetsp;
1841
1842     TAINT_NOT;
1843     if (gimme == G_VOID)
1844         ; /* do nothing */
1845     else if (gimme == G_SCALAR) {
1846         if (mark < SP)
1847             *++newsp = sv_mortalcopy(*SP);
1848         else
1849             *++newsp = &PL_sv_undef;
1850     }
1851     else {
1852         while (mark < SP) {
1853             *++newsp = sv_mortalcopy(*++mark);
1854             TAINT_NOT;          /* Each item is independent */
1855         }
1856     }
1857     SP = newsp;
1858     PUTBACK;
1859
1860     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1861     PL_curpm = newpm;   /* ... and pop $1 et al */
1862
1863     LEAVE;
1864     LEAVE;
1865
1866     return NORMAL;
1867 }
1868
1869 PP(pp_return)
1870 {
1871     dSP; dMARK;
1872     I32 cxix;
1873     register PERL_CONTEXT *cx;
1874     bool popsub2 = FALSE;
1875     bool clear_errsv = FALSE;
1876     I32 gimme;
1877     SV **newsp;
1878     PMOP *newpm;
1879     I32 optype = 0;
1880     SV *sv;
1881
1882     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1883         if (cxstack_ix == PL_sortcxix
1884             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1885         {
1886             if (cxstack_ix > PL_sortcxix)
1887                 dounwind(PL_sortcxix);
1888             AvARRAY(PL_curstack)[1] = *SP;
1889             PL_stack_sp = PL_stack_base + 1;
1890             return 0;
1891         }
1892     }
1893
1894     cxix = dopoptosub(cxstack_ix);
1895     if (cxix < 0)
1896         DIE(aTHX_ "Can't return outside a subroutine");
1897     if (cxix < cxstack_ix)
1898         dounwind(cxix);
1899
1900     POPBLOCK(cx,newpm);
1901     switch (CxTYPE(cx)) {
1902     case CXt_SUB:
1903         popsub2 = TRUE;
1904         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1905         break;
1906     case CXt_EVAL:
1907         if (!(PL_in_eval & EVAL_KEEPERR))
1908             clear_errsv = TRUE;
1909         POPEVAL(cx);
1910         if (CxTRYBLOCK(cx))
1911             break;
1912         lex_end();
1913         if (optype == OP_REQUIRE &&
1914             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1915         {
1916             /* Unassume the success we assumed earlier. */
1917             SV *nsv = cx->blk_eval.old_namesv;
1918             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1919             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1920         }
1921         break;
1922     case CXt_FORMAT:
1923         POPFORMAT(cx);
1924         break;
1925     default:
1926         DIE(aTHX_ "panic: return");
1927     }
1928
1929     TAINT_NOT;
1930     if (gimme == G_SCALAR) {
1931         if (MARK < SP) {
1932             if (popsub2) {
1933                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1934                     if (SvTEMP(TOPs)) {
1935                         *++newsp = SvREFCNT_inc(*SP);
1936                         FREETMPS;
1937                         sv_2mortal(*newsp);
1938                     }
1939                     else {
1940                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1941                         FREETMPS;
1942                         *++newsp = sv_mortalcopy(sv);
1943                         SvREFCNT_dec(sv);
1944                     }
1945                 }
1946                 else
1947                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1948             }
1949             else
1950                 *++newsp = sv_mortalcopy(*SP);
1951         }
1952         else
1953             *++newsp = &PL_sv_undef;
1954     }
1955     else if (gimme == G_ARRAY) {
1956         while (++MARK <= SP) {
1957             *++newsp = (popsub2 && SvTEMP(*MARK))
1958                         ? *MARK : sv_mortalcopy(*MARK);
1959             TAINT_NOT;          /* Each item is independent */
1960         }
1961     }
1962     PL_stack_sp = newsp;
1963
1964     LEAVE;
1965     /* Stack values are safe: */
1966     if (popsub2) {
1967         cxstack_ix--;
1968         POPSUB(cx,sv);  /* release CV and @_ ... */
1969     }
1970     else
1971         sv = Nullsv;
1972     PL_curpm = newpm;   /* ... and pop $1 et al */
1973
1974     LEAVESUB(sv);
1975     if (clear_errsv)
1976         sv_setpv(ERRSV,"");
1977     return pop_return();
1978 }
1979
1980 PP(pp_last)
1981 {
1982     dSP;
1983     I32 cxix;
1984     register PERL_CONTEXT *cx;
1985     I32 pop2 = 0;
1986     I32 gimme;
1987     I32 optype;
1988     OP *nextop;
1989     SV **newsp;
1990     PMOP *newpm;
1991     SV **mark;
1992     SV *sv = Nullsv;
1993
1994     if (PL_op->op_flags & OPf_SPECIAL) {
1995         cxix = dopoptoloop(cxstack_ix);
1996         if (cxix < 0)
1997             DIE(aTHX_ "Can't \"last\" outside a loop block");
1998     }
1999     else {
2000         cxix = dopoptolabel(cPVOP->op_pv);
2001         if (cxix < 0)
2002             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2003     }
2004     if (cxix < cxstack_ix)
2005         dounwind(cxix);
2006
2007     POPBLOCK(cx,newpm);
2008     cxstack_ix++; /* temporarily protect top context */
2009     mark = newsp;
2010     switch (CxTYPE(cx)) {
2011     case CXt_LOOP:
2012         pop2 = CXt_LOOP;
2013         newsp = PL_stack_base + cx->blk_loop.resetsp;
2014         nextop = cx->blk_loop.last_op->op_next;
2015         break;
2016     case CXt_SUB:
2017         pop2 = CXt_SUB;
2018         nextop = pop_return();
2019         break;
2020     case CXt_EVAL:
2021         POPEVAL(cx);
2022         nextop = pop_return();
2023         break;
2024     case CXt_FORMAT:
2025         POPFORMAT(cx);
2026         nextop = pop_return();
2027         break;
2028     default:
2029         DIE(aTHX_ "panic: last");
2030     }
2031
2032     TAINT_NOT;
2033     if (gimme == G_SCALAR) {
2034         if (MARK < SP)
2035             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2036                         ? *SP : sv_mortalcopy(*SP);
2037         else
2038             *++newsp = &PL_sv_undef;
2039     }
2040     else if (gimme == G_ARRAY) {
2041         while (++MARK <= SP) {
2042             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2043                         ? *MARK : sv_mortalcopy(*MARK);
2044             TAINT_NOT;          /* Each item is independent */
2045         }
2046     }
2047     SP = newsp;
2048     PUTBACK;
2049
2050     LEAVE;
2051     cxstack_ix--;
2052     /* Stack values are safe: */
2053     switch (pop2) {
2054     case CXt_LOOP:
2055         POPLOOP(cx);    /* release loop vars ... */
2056         LEAVE;
2057         break;
2058     case CXt_SUB:
2059         POPSUB(cx,sv);  /* release CV and @_ ... */
2060         break;
2061     }
2062     PL_curpm = newpm;   /* ... and pop $1 et al */
2063
2064     LEAVESUB(sv);
2065     return nextop;
2066 }
2067
2068 PP(pp_next)
2069 {
2070     I32 cxix;
2071     register PERL_CONTEXT *cx;
2072     I32 inner;
2073
2074     if (PL_op->op_flags & OPf_SPECIAL) {
2075         cxix = dopoptoloop(cxstack_ix);
2076         if (cxix < 0)
2077             DIE(aTHX_ "Can't \"next\" outside a loop block");
2078     }
2079     else {
2080         cxix = dopoptolabel(cPVOP->op_pv);
2081         if (cxix < 0)
2082             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2083     }
2084     if (cxix < cxstack_ix)
2085         dounwind(cxix);
2086
2087     /* clear off anything above the scope we're re-entering, but
2088      * save the rest until after a possible continue block */
2089     inner = PL_scopestack_ix;
2090     TOPBLOCK(cx);
2091     if (PL_scopestack_ix < inner)
2092         leave_scope(PL_scopestack[PL_scopestack_ix]);
2093     return cx->blk_loop.next_op;
2094 }
2095
2096 PP(pp_redo)
2097 {
2098     I32 cxix;
2099     register PERL_CONTEXT *cx;
2100     I32 oldsave;
2101
2102     if (PL_op->op_flags & OPf_SPECIAL) {
2103         cxix = dopoptoloop(cxstack_ix);
2104         if (cxix < 0)
2105             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2106     }
2107     else {
2108         cxix = dopoptolabel(cPVOP->op_pv);
2109         if (cxix < 0)
2110             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2111     }
2112     if (cxix < cxstack_ix)
2113         dounwind(cxix);
2114
2115     TOPBLOCK(cx);
2116     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2117     LEAVE_SCOPE(oldsave);
2118     return cx->blk_loop.redo_op;
2119 }
2120
2121 STATIC OP *
2122 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2123 {
2124     OP *kid = Nullop;
2125     OP **ops = opstack;
2126     static char too_deep[] = "Target of goto is too deeply nested";
2127
2128     if (ops >= oplimit)
2129         Perl_croak(aTHX_ too_deep);
2130     if (o->op_type == OP_LEAVE ||
2131         o->op_type == OP_SCOPE ||
2132         o->op_type == OP_LEAVELOOP ||
2133         o->op_type == OP_LEAVESUB ||
2134         o->op_type == OP_LEAVETRY)
2135     {
2136         *ops++ = cUNOPo->op_first;
2137         if (ops >= oplimit)
2138             Perl_croak(aTHX_ too_deep);
2139     }
2140     *ops = 0;
2141     if (o->op_flags & OPf_KIDS) {
2142         /* First try all the kids at this level, since that's likeliest. */
2143         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2144             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2145                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2146                 return kid;
2147         }
2148         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2149             if (kid == PL_lastgotoprobe)
2150                 continue;
2151             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2152                 if (ops == opstack)
2153                     *ops++ = kid;
2154                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2155                          ops[-1]->op_type == OP_DBSTATE)
2156                     ops[-1] = kid;
2157                 else
2158                     *ops++ = kid;
2159             }
2160             if ((o = dofindlabel(kid, label, ops, oplimit)))
2161                 return o;
2162         }
2163     }
2164     *ops = 0;
2165     return 0;
2166 }
2167
2168 PP(pp_dump)
2169 {
2170     return pp_goto();
2171     /*NOTREACHED*/
2172 }
2173
2174 PP(pp_goto)
2175 {
2176     dSP;
2177     OP *retop = 0;
2178     I32 ix;
2179     register PERL_CONTEXT *cx;
2180 #define GOTO_DEPTH 64
2181     OP *enterops[GOTO_DEPTH];
2182     char *label;
2183     int do_dump = (PL_op->op_type == OP_DUMP);
2184     static char must_have_label[] = "goto must have label";
2185
2186     label = 0;
2187     if (PL_op->op_flags & OPf_STACKED) {
2188         SV *sv = POPs;
2189         STRLEN n_a;
2190
2191         /* This egregious kludge implements goto &subroutine */
2192         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2193             I32 cxix;
2194             register PERL_CONTEXT *cx;
2195             CV* cv = (CV*)SvRV(sv);
2196             SV** mark;
2197             I32 items = 0;
2198             I32 oldsave;
2199
2200         retry:
2201             if (!CvROOT(cv) && !CvXSUB(cv)) {
2202                 GV *gv = CvGV(cv);
2203                 GV *autogv;
2204                 if (gv) {
2205                     SV *tmpstr;
2206                     /* autoloaded stub? */
2207                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2208                         goto retry;
2209                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2210                                           GvNAMELEN(gv), FALSE);
2211                     if (autogv && (cv = GvCV(autogv)))
2212                         goto retry;
2213                     tmpstr = sv_newmortal();
2214                     gv_efullname3(tmpstr, gv, Nullch);
2215                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2216                 }
2217                 DIE(aTHX_ "Goto undefined subroutine");
2218             }
2219
2220             /* First do some returnish stuff. */
2221             SvREFCNT_inc(cv); /* avoid premature free during unwind */
2222             FREETMPS;
2223             cxix = dopoptosub(cxstack_ix);
2224             if (cxix < 0)
2225                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2226             if (cxix < cxstack_ix)
2227                 dounwind(cxix);
2228             TOPBLOCK(cx);
2229             if (CxREALEVAL(cx))
2230                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2231             mark = PL_stack_sp;
2232             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2233                 /* put @_ back onto stack */
2234                 AV* av = cx->blk_sub.argarray;
2235
2236                 items = AvFILLp(av) + 1;
2237                 PL_stack_sp++;
2238                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2239                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2240                 PL_stack_sp += items;
2241                 SvREFCNT_dec(GvAV(PL_defgv));
2242                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2243                 /* abandon @_ if it got reified */
2244                 if (AvREAL(av)) {
2245                     (void)sv_2mortal((SV*)av);  /* delay until return */
2246                     av = newAV();
2247                     av_extend(av, items-1);
2248                     AvFLAGS(av) = AVf_REIFY;
2249                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2250                 }
2251                 else
2252                     CLEAR_ARGARRAY(av);
2253             }
2254             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2255                 AV* av;
2256                 av = GvAV(PL_defgv);
2257                 items = AvFILLp(av) + 1;
2258                 PL_stack_sp++;
2259                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2260                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2261                 PL_stack_sp += items;
2262             }
2263             if (CxTYPE(cx) == CXt_SUB &&
2264                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2265                 SvREFCNT_dec(cx->blk_sub.cv);
2266             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2267             LEAVE_SCOPE(oldsave);
2268
2269             /* Now do some callish stuff. */
2270             SAVETMPS;
2271             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2272             if (CvXSUB(cv)) {
2273 #ifdef PERL_XSUB_OLDSTYLE
2274                 if (CvOLDSTYLE(cv)) {
2275                     I32 (*fp3)(int,int,int);
2276                     while (SP > mark) {
2277                         SP[1] = SP[0];
2278                         SP--;
2279                     }
2280                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2281                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2282                                    mark - PL_stack_base + 1,
2283                                    items);
2284                     SP = PL_stack_base + items;
2285                 }
2286                 else
2287 #endif /* PERL_XSUB_OLDSTYLE */
2288                 {
2289                     SV **newsp;
2290                     I32 gimme;
2291
2292                     PL_stack_sp--;              /* There is no cv arg. */
2293                     /* Push a mark for the start of arglist */
2294                     PUSHMARK(mark);
2295                     (void)(*CvXSUB(cv))(aTHX_ cv);
2296                     /* Pop the current context like a decent sub should */
2297                     POPBLOCK(cx, PL_curpm);
2298                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2299                 }
2300                 LEAVE;
2301                 return pop_return();
2302             }
2303             else {
2304                 AV* padlist = CvPADLIST(cv);
2305                 if (CxTYPE(cx) == CXt_EVAL) {
2306                     PL_in_eval = cx->blk_eval.old_in_eval;
2307                     PL_eval_root = cx->blk_eval.old_eval_root;
2308                     cx->cx_type = CXt_SUB;
2309                     cx->blk_sub.hasargs = 0;
2310                 }
2311                 cx->blk_sub.cv = cv;
2312                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2313
2314                 CvDEPTH(cv)++;
2315                 if (CvDEPTH(cv) < 2)
2316                     (void)SvREFCNT_inc(cv);
2317                 else {
2318                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2319                         sub_crush_depth(cv);
2320                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2321                 }
2322                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2323                 if (cx->blk_sub.hasargs)
2324                 {
2325                     AV* av = (AV*)PAD_SVl(0);
2326                     SV** ary;
2327
2328                     cx->blk_sub.savearray = GvAV(PL_defgv);
2329                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2330                     CX_CURPAD_SAVE(cx->blk_sub);
2331                     cx->blk_sub.argarray = av;
2332                     ++mark;
2333
2334                     if (items >= AvMAX(av) + 1) {
2335                         ary = AvALLOC(av);
2336                         if (AvARRAY(av) != ary) {
2337                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2338                             SvPVX(av) = (char*)ary;
2339                         }
2340                         if (items >= AvMAX(av) + 1) {
2341                             AvMAX(av) = items - 1;
2342                             Renew(ary,items+1,SV*);
2343                             AvALLOC(av) = ary;
2344                             SvPVX(av) = (char*)ary;
2345                         }
2346                     }
2347                     Copy(mark,AvARRAY(av),items,SV*);
2348                     AvFILLp(av) = items - 1;
2349                     assert(!AvREAL(av));
2350                     while (items--) {
2351                         if (*mark)
2352                             SvTEMP_off(*mark);
2353                         mark++;
2354                     }
2355                 }
2356                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2357                     /*
2358                      * We do not care about using sv to call CV;
2359                      * it's for informational purposes only.
2360                      */
2361                     SV *sv = GvSV(PL_DBsub);
2362                     CV *gotocv;
2363
2364                     if (PERLDB_SUB_NN) {
2365                         (void)SvUPGRADE(sv, SVt_PVIV);
2366                         (void)SvIOK_on(sv);
2367                         SAVEIV(SvIVX(sv));
2368                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2369                     } else {
2370                         save_item(sv);
2371                         gv_efullname3(sv, CvGV(cv), Nullch);
2372                     }
2373                     if (  PERLDB_GOTO
2374                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2375                         PUSHMARK( PL_stack_sp );
2376                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2377                         PL_stack_sp--;
2378                     }
2379                 }
2380                 RETURNOP(CvSTART(cv));
2381             }
2382         }
2383         else {
2384             label = SvPV(sv,n_a);
2385             if (!(do_dump || *label))
2386                 DIE(aTHX_ must_have_label);
2387         }
2388     }
2389     else if (PL_op->op_flags & OPf_SPECIAL) {
2390         if (! do_dump)
2391             DIE(aTHX_ must_have_label);
2392     }
2393     else
2394         label = cPVOP->op_pv;
2395
2396     if (label && *label) {
2397         OP *gotoprobe = 0;
2398         bool leaving_eval = FALSE;
2399         bool in_block = FALSE;
2400         PERL_CONTEXT *last_eval_cx = 0;
2401
2402         /* find label */
2403
2404         PL_lastgotoprobe = 0;
2405         *enterops = 0;
2406         for (ix = cxstack_ix; ix >= 0; ix--) {
2407             cx = &cxstack[ix];
2408             switch (CxTYPE(cx)) {
2409             case CXt_EVAL:
2410                 leaving_eval = TRUE;
2411                 if (!CxTRYBLOCK(cx)) {
2412                     gotoprobe = (last_eval_cx ?
2413                                 last_eval_cx->blk_eval.old_eval_root :
2414                                 PL_eval_root);
2415                     last_eval_cx = cx;
2416                     break;
2417                 }
2418                 /* else fall through */
2419             case CXt_LOOP:
2420                 gotoprobe = cx->blk_oldcop->op_sibling;
2421                 break;
2422             case CXt_SUBST:
2423                 continue;
2424             case CXt_BLOCK:
2425                 if (ix) {
2426                     gotoprobe = cx->blk_oldcop->op_sibling;
2427                     in_block = TRUE;
2428                 } else
2429                     gotoprobe = PL_main_root;
2430                 break;
2431             case CXt_SUB:
2432                 if (CvDEPTH(cx->blk_sub.cv)) {
2433                     gotoprobe = CvROOT(cx->blk_sub.cv);
2434                     break;
2435                 }
2436                 /* FALL THROUGH */
2437             case CXt_FORMAT:
2438             case CXt_NULL:
2439                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2440             default:
2441                 if (ix)
2442                     DIE(aTHX_ "panic: goto");
2443                 gotoprobe = PL_main_root;
2444                 break;
2445             }
2446             if (gotoprobe) {
2447                 retop = dofindlabel(gotoprobe, label,
2448                                     enterops, enterops + GOTO_DEPTH);
2449                 if (retop)
2450                     break;
2451             }
2452             PL_lastgotoprobe = gotoprobe;
2453         }
2454         if (!retop)
2455             DIE(aTHX_ "Can't find label %s", label);
2456
2457         /* if we're leaving an eval, check before we pop any frames
2458            that we're not going to punt, otherwise the error
2459            won't be caught */
2460
2461         if (leaving_eval && *enterops && enterops[1]) {
2462             I32 i;
2463             for (i = 1; enterops[i]; i++)
2464                 if (enterops[i]->op_type == OP_ENTERITER)
2465                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2466         }
2467
2468         /* pop unwanted frames */
2469
2470         if (ix < cxstack_ix) {
2471             I32 oldsave;
2472
2473             if (ix < 0)
2474                 ix = 0;
2475             dounwind(ix);
2476             TOPBLOCK(cx);
2477             oldsave = PL_scopestack[PL_scopestack_ix];
2478             LEAVE_SCOPE(oldsave);
2479         }
2480
2481         /* push wanted frames */
2482
2483         if (*enterops && enterops[1]) {
2484             OP *oldop = PL_op;
2485             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2486             for (; enterops[ix]; ix++) {
2487                 PL_op = enterops[ix];
2488                 /* Eventually we may want to stack the needed arguments
2489                  * for each op.  For now, we punt on the hard ones. */
2490                 if (PL_op->op_type == OP_ENTERITER)
2491                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2492                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2493             }
2494             PL_op = oldop;
2495         }
2496     }
2497
2498     if (do_dump) {
2499 #ifdef VMS
2500         if (!retop) retop = PL_main_start;
2501 #endif
2502         PL_restartop = retop;
2503         PL_do_undump = TRUE;
2504
2505         my_unexec();
2506
2507         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2508         PL_do_undump = FALSE;
2509     }
2510
2511     RETURNOP(retop);
2512 }
2513
2514 PP(pp_exit)
2515 {
2516     dSP;
2517     I32 anum;
2518
2519     if (MAXARG < 1)
2520         anum = 0;
2521     else {
2522         anum = SvIVx(POPs);
2523 #ifdef VMS
2524         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2525             anum = 0;
2526         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2527 #endif
2528     }
2529     PL_exit_flags |= PERL_EXIT_EXPECTED;
2530     my_exit(anum);
2531     PUSHs(&PL_sv_undef);
2532     RETURN;
2533 }
2534
2535 #ifdef NOTYET
2536 PP(pp_nswitch)
2537 {
2538     dSP;
2539     NV value = SvNVx(GvSV(cCOP->cop_gv));
2540     register I32 match = I_32(value);
2541
2542     if (value < 0.0) {
2543         if (((NV)match) > value)
2544             --match;            /* was fractional--truncate other way */
2545     }
2546     match -= cCOP->uop.scop.scop_offset;
2547     if (match < 0)
2548         match = 0;
2549     else if (match > cCOP->uop.scop.scop_max)
2550         match = cCOP->uop.scop.scop_max;
2551     PL_op = cCOP->uop.scop.scop_next[match];
2552     RETURNOP(PL_op);
2553 }
2554
2555 PP(pp_cswitch)
2556 {
2557     dSP;
2558     register I32 match;
2559
2560     if (PL_multiline)
2561         PL_op = PL_op->op_next;                 /* can't assume anything */
2562     else {
2563         STRLEN n_a;
2564         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2565         match -= cCOP->uop.scop.scop_offset;
2566         if (match < 0)
2567             match = 0;
2568         else if (match > cCOP->uop.scop.scop_max)
2569             match = cCOP->uop.scop.scop_max;
2570         PL_op = cCOP->uop.scop.scop_next[match];
2571     }
2572     RETURNOP(PL_op);
2573 }
2574 #endif
2575
2576 /* Eval. */
2577
2578 STATIC void
2579 S_save_lines(pTHX_ AV *array, SV *sv)
2580 {
2581     register char *s = SvPVX(sv);
2582     register char *send = SvPVX(sv) + SvCUR(sv);
2583     register char *t;
2584     register I32 line = 1;
2585
2586     while (s && s < send) {
2587         SV *tmpstr = NEWSV(85,0);
2588
2589         sv_upgrade(tmpstr, SVt_PVMG);
2590         t = strchr(s, '\n');
2591         if (t)
2592             t++;
2593         else
2594             t = send;
2595
2596         sv_setpvn(tmpstr, s, t - s);
2597         av_store(array, line++, tmpstr);
2598         s = t;
2599     }
2600 }
2601
2602 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2603 STATIC void *
2604 S_docatch_body(pTHX_ va_list args)
2605 {
2606     return docatch_body();
2607 }
2608 #endif
2609
2610 STATIC void *
2611 S_docatch_body(pTHX)
2612 {
2613     CALLRUNOPS(aTHX);
2614     return NULL;
2615 }
2616
2617 STATIC OP *
2618 S_docatch(pTHX_ OP *o)
2619 {
2620     int ret;
2621     OP *oldop = PL_op;
2622     OP *retop;
2623     volatile PERL_SI *cursi = PL_curstackinfo;
2624     dJMPENV;
2625
2626 #ifdef DEBUGGING
2627     assert(CATCH_GET == TRUE);
2628 #endif
2629     PL_op = o;
2630
2631     /* Normally, the leavetry at the end of this block of ops will
2632      * pop an op off the return stack and continue there. By setting
2633      * the op to Nullop, we force an exit from the inner runops()
2634      * loop. DAPM.
2635      */
2636     retop = pop_return();
2637     push_return(Nullop);
2638
2639 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2640  redo_body:
2641     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2642 #else
2643     JMPENV_PUSH(ret);
2644 #endif
2645     switch (ret) {
2646     case 0:
2647 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2648  redo_body:
2649         docatch_body();
2650 #endif
2651         break;
2652     case 3:
2653         /* die caught by an inner eval - continue inner loop */
2654         if (PL_restartop && cursi == PL_curstackinfo) {
2655             PL_op = PL_restartop;
2656             PL_restartop = 0;
2657             goto redo_body;
2658         }
2659         /* a die in this eval - continue in outer loop */
2660         if (!PL_restartop)
2661             break;
2662         /* FALL THROUGH */
2663     default:
2664         JMPENV_POP;
2665         PL_op = oldop;
2666         JMPENV_JUMP(ret);
2667         /* NOTREACHED */
2668     }
2669     JMPENV_POP;
2670     PL_op = oldop;
2671     return retop;
2672 }
2673
2674 OP *
2675 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2676 /* sv Text to convert to OP tree. */
2677 /* startop op_free() this to undo. */
2678 /* code Short string id of the caller. */
2679 {
2680     dSP;                                /* Make POPBLOCK work. */
2681     PERL_CONTEXT *cx;
2682     SV **newsp;
2683     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2684     I32 optype;
2685     OP dummy;
2686     OP *rop;
2687     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2688     char *tmpbuf = tbuf;
2689     char *safestr;
2690     int runtime;
2691     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2692
2693     ENTER;
2694     lex_start(sv);
2695     SAVETMPS;
2696     /* switch to eval mode */
2697
2698     if (IN_PERL_COMPILETIME) {
2699         SAVECOPSTASH_FREE(&PL_compiling);
2700         CopSTASH_set(&PL_compiling, PL_curstash);
2701     }
2702     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2703         SV *sv = sv_newmortal();
2704         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2705                        code, (unsigned long)++PL_evalseq,
2706                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2707         tmpbuf = SvPVX(sv);
2708     }
2709     else
2710         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2711     SAVECOPFILE_FREE(&PL_compiling);
2712     CopFILE_set(&PL_compiling, tmpbuf+2);
2713     SAVECOPLINE(&PL_compiling);
2714     CopLINE_set(&PL_compiling, 1);
2715     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2716        deleting the eval's FILEGV from the stash before gv_check() runs
2717        (i.e. before run-time proper). To work around the coredump that
2718        ensues, we always turn GvMULTI_on for any globals that were
2719        introduced within evals. See force_ident(). GSAR 96-10-12 */
2720     safestr = savepv(tmpbuf);
2721     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2722     SAVEHINTS();
2723 #ifdef OP_IN_REGISTER
2724     PL_opsave = op;
2725 #else
2726     SAVEVPTR(PL_op);
2727 #endif
2728
2729     /* we get here either during compilation, or via pp_regcomp at runtime */
2730     runtime = IN_PERL_RUNTIME;
2731     if (runtime)
2732         runcv = find_runcv(NULL);
2733
2734     PL_op = &dummy;
2735     PL_op->op_type = OP_ENTEREVAL;
2736     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2737     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2738     PUSHEVAL(cx, 0, Nullgv);
2739
2740     if (runtime)
2741         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2742     else
2743         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2744     POPBLOCK(cx,PL_curpm);
2745     POPEVAL(cx);
2746
2747     (*startop)->op_type = OP_NULL;
2748     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2749     lex_end();
2750     /* XXX DAPM do this properly one year */
2751     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2752     LEAVE;
2753     if (IN_PERL_COMPILETIME)
2754         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2755 #ifdef OP_IN_REGISTER
2756     op = PL_opsave;
2757 #endif
2758     return rop;
2759 }
2760
2761
2762 /*
2763 =for apidoc find_runcv
2764
2765 Locate the CV corresponding to the currently executing sub or eval.
2766 If db_seqp is non_null, skip CVs that are in the DB package and populate
2767 *db_seqp with the cop sequence number at the point that the DB:: code was
2768 entered. (allows debuggers to eval in the scope of the breakpoint rather
2769 than in in the scope of the debuger itself).
2770
2771 =cut
2772 */
2773
2774 CV*
2775 Perl_find_runcv(pTHX_ U32 *db_seqp)
2776 {
2777     I32          ix;
2778     PERL_SI      *si;
2779     PERL_CONTEXT *cx;
2780
2781     if (db_seqp)
2782         *db_seqp = PL_curcop->cop_seq;
2783     for (si = PL_curstackinfo; si; si = si->si_prev) {
2784         for (ix = si->si_cxix; ix >= 0; ix--) {
2785             cx = &(si->si_cxstack[ix]);
2786             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2787                 CV *cv = cx->blk_sub.cv;
2788                 /* skip DB:: code */
2789                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2790                     *db_seqp = cx->blk_oldcop->cop_seq;
2791                     continue;
2792                 }
2793                 return cv;
2794             }
2795             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2796                 return PL_compcv;
2797         }
2798     }
2799     return PL_main_cv;
2800 }
2801
2802
2803 /* Compile a require/do, an eval '', or a /(?{...})/.
2804  * In the last case, startop is non-null, and contains the address of
2805  * a pointer that should be set to the just-compiled code.
2806  * outside is the lexically enclosing CV (if any) that invoked us.
2807  */
2808
2809 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2810 STATIC OP *
2811 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2812 {
2813     dSP;
2814     OP *saveop = PL_op;
2815
2816     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2817                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2818                   : EVAL_INEVAL);
2819
2820     PUSHMARK(SP);
2821
2822     SAVESPTR(PL_compcv);
2823     PL_compcv = (CV*)NEWSV(1104,0);
2824     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2825     CvEVAL_on(PL_compcv);
2826     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2827     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2828
2829     CvOUTSIDE_SEQ(PL_compcv) = seq;
2830     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2831
2832     /* set up a scratch pad */
2833
2834     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2835
2836
2837     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2838
2839     /* make sure we compile in the right package */
2840
2841     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2842         SAVESPTR(PL_curstash);
2843         PL_curstash = CopSTASH(PL_curcop);
2844     }
2845     SAVESPTR(PL_beginav);
2846     PL_beginav = newAV();
2847     SAVEFREESV(PL_beginav);
2848     SAVEI32(PL_error_count);
2849
2850     /* try to compile it */
2851
2852     PL_eval_root = Nullop;
2853     PL_error_count = 0;
2854     PL_curcop = &PL_compiling;
2855     PL_curcop->cop_arybase = 0;
2856     if (saveop && saveop->op_flags & OPf_SPECIAL)
2857         PL_in_eval |= EVAL_KEEPERR;
2858     else
2859         sv_setpv(ERRSV,"");
2860     if (yyparse() || PL_error_count || !PL_eval_root) {
2861         SV **newsp;                     /* Used by POPBLOCK. */
2862        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2863         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2864         STRLEN n_a;
2865
2866         PL_op = saveop;
2867         if (PL_eval_root) {
2868             op_free(PL_eval_root);
2869             PL_eval_root = Nullop;
2870         }
2871         SP = PL_stack_base + POPMARK;           /* pop original mark */
2872         if (!startop) {
2873             POPBLOCK(cx,PL_curpm);
2874             POPEVAL(cx);
2875             pop_return();
2876         }
2877         lex_end();
2878         LEAVE;
2879         if (optype == OP_REQUIRE) {
2880             char* msg = SvPVx(ERRSV, n_a);
2881            SV *nsv = cx->blk_eval.old_namesv;
2882            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2883                           &PL_sv_undef, 0);
2884             DIE(aTHX_ "%sCompilation failed in require",
2885                 *msg ? msg : "Unknown error\n");
2886         }
2887         else if (startop) {
2888             char* msg = SvPVx(ERRSV, n_a);
2889
2890             POPBLOCK(cx,PL_curpm);
2891             POPEVAL(cx);
2892             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2893                        (*msg ? msg : "Unknown error\n"));
2894         }
2895         else {
2896             char* msg = SvPVx(ERRSV, n_a);
2897             if (!*msg) {
2898                 sv_setpv(ERRSV, "Compilation error");
2899             }
2900         }
2901         RETPUSHUNDEF;
2902     }
2903     CopLINE_set(&PL_compiling, 0);
2904     if (startop) {
2905         *startop = PL_eval_root;
2906     } else
2907         SAVEFREEOP(PL_eval_root);
2908
2909     /* Set the context for this new optree.
2910      * If the last op is an OP_REQUIRE, force scalar context.
2911      * Otherwise, propagate the context from the eval(). */
2912     if (PL_eval_root->op_type == OP_LEAVEEVAL
2913             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2914             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2915             == OP_REQUIRE)
2916         scalar(PL_eval_root);
2917     else if (gimme & G_VOID)
2918         scalarvoid(PL_eval_root);
2919     else if (gimme & G_ARRAY)
2920         list(PL_eval_root);
2921     else
2922         scalar(PL_eval_root);
2923
2924     DEBUG_x(dump_eval());
2925
2926     /* Register with debugger: */
2927     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2928         CV *cv = get_cv("DB::postponed", FALSE);
2929         if (cv) {
2930             dSP;
2931             PUSHMARK(SP);
2932             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2933             PUTBACK;
2934             call_sv((SV*)cv, G_DISCARD);
2935         }
2936     }
2937
2938     /* compiled okay, so do it */
2939
2940     CvDEPTH(PL_compcv) = 1;
2941     SP = PL_stack_base + POPMARK;               /* pop original mark */
2942     PL_op = saveop;                     /* The caller may need it. */
2943     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2944
2945     RETURNOP(PL_eval_start);
2946 }
2947
2948 STATIC PerlIO *
2949 S_doopen_pm(pTHX_ const char *name, const char *mode)
2950 {
2951 #ifndef PERL_DISABLE_PMC
2952     STRLEN namelen = strlen(name);
2953     PerlIO *fp;
2954
2955     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2956         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2957         char *pmc = SvPV_nolen(pmcsv);
2958         Stat_t pmstat;
2959         Stat_t pmcstat;
2960         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2961             fp = PerlIO_open(name, mode);
2962         }
2963         else {
2964             if (PerlLIO_stat(name, &pmstat) < 0 ||
2965                 pmstat.st_mtime < pmcstat.st_mtime)
2966             {
2967                 fp = PerlIO_open(pmc, mode);
2968             }
2969             else {
2970                 fp = PerlIO_open(name, mode);
2971             }
2972         }
2973         SvREFCNT_dec(pmcsv);
2974     }
2975     else {
2976         fp = PerlIO_open(name, mode);
2977     }
2978     return fp;
2979 #else
2980     return PerlIO_open(name, mode);
2981 #endif /* !PERL_DISABLE_PMC */
2982 }
2983
2984 PP(pp_require)
2985 {
2986     dSP;
2987     register PERL_CONTEXT *cx;
2988     SV *sv;
2989     char *name;
2990     STRLEN len;
2991     char *tryname = Nullch;
2992     SV *namesv = Nullsv;
2993     SV** svp;
2994     I32 gimme = GIMME_V;
2995     PerlIO *tryrsfp = 0;
2996     STRLEN n_a;
2997     int filter_has_file = 0;
2998     GV *filter_child_proc = 0;
2999     SV *filter_state = 0;
3000     SV *filter_sub = 0;
3001     SV *hook_sv = 0;
3002     SV *encoding;
3003     OP *op;
3004
3005     sv = POPs;
3006     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
3007         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
3008             UV rev = 0, ver = 0, sver = 0;
3009             STRLEN len;
3010             U8 *s = (U8*)SvPVX(sv);
3011             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3012             if (s < end) {
3013                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3014                 s += len;
3015                 if (s < end) {
3016                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3017                     s += len;
3018                     if (s < end)
3019                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3020                 }
3021             }
3022             if (PERL_REVISION < rev
3023                 || (PERL_REVISION == rev
3024                     && (PERL_VERSION < ver
3025                         || (PERL_VERSION == ver
3026                             && PERL_SUBVERSION < sver))))
3027             {
3028                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3029                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3030                     PERL_VERSION, PERL_SUBVERSION);
3031             }
3032             if (ckWARN(WARN_PORTABLE))
3033                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3034                         "v-string in use/require non-portable");
3035             RETPUSHYES;
3036         }
3037         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3038             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3039                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3040                 + 0.00000099 < SvNV(sv))
3041             {
3042                 NV nrev = SvNV(sv);
3043                 UV rev = (UV)nrev;
3044                 NV nver = (nrev - rev) * 1000;
3045                 UV ver = (UV)(nver + 0.0009);
3046                 NV nsver = (nver - ver) * 1000;
3047                 UV sver = (UV)(nsver + 0.0009);
3048
3049                 /* help out with the "use 5.6" confusion */
3050                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3051                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3052                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3053                         "this is only v%d.%d.%d, stopped",
3054                         rev, ver, sver, rev, ver/100,
3055                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3056                 }
3057                 else {
3058                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3059                         "this is only v%d.%d.%d, stopped",
3060                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3061                         PERL_SUBVERSION);
3062                 }
3063             }
3064             RETPUSHYES;
3065         }
3066     }
3067     name = SvPV(sv, len);
3068     if (!(name && len > 0 && *name))
3069         DIE(aTHX_ "Null filename used");
3070     TAINT_PROPER("require");
3071     if (PL_op->op_type == OP_REQUIRE &&
3072        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3073        if (*svp != &PL_sv_undef)
3074            RETPUSHYES;
3075        else
3076            DIE(aTHX_ "Compilation failed in require");
3077     }
3078
3079     /* prepare to compile file */
3080
3081     if (path_is_absolute(name)) {
3082         tryname = name;
3083         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3084     }
3085 #ifdef MACOS_TRADITIONAL
3086     if (!tryrsfp) {
3087         char newname[256];
3088
3089         MacPerl_CanonDir(name, newname, 1);
3090         if (path_is_absolute(newname)) {
3091             tryname = newname;
3092             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3093         }
3094     }
3095 #endif
3096     if (!tryrsfp) {
3097         AV *ar = GvAVn(PL_incgv);
3098         I32 i;
3099 #ifdef VMS
3100         char *unixname;
3101         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3102 #endif
3103         {
3104             namesv = NEWSV(806, 0);
3105             for (i = 0; i <= AvFILL(ar); i++) {
3106                 SV *dirsv = *av_fetch(ar, i, TRUE);
3107
3108                 if (SvROK(dirsv)) {
3109                     int count;
3110                     SV *loader = dirsv;
3111
3112                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3113                         && !sv_isobject(loader))
3114                     {
3115                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3116                     }
3117
3118                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3119                                    PTR2UV(SvRV(dirsv)), name);
3120                     tryname = SvPVX(namesv);
3121                     tryrsfp = 0;
3122
3123                     ENTER;
3124                     SAVETMPS;
3125                     EXTEND(SP, 2);
3126
3127                     PUSHMARK(SP);
3128                     PUSHs(dirsv);
3129                     PUSHs(sv);
3130                     PUTBACK;
3131                     if (sv_isobject(loader))
3132                         count = call_method("INC", G_ARRAY);
3133                     else
3134                         count = call_sv(loader, G_ARRAY);
3135                     SPAGAIN;
3136
3137                     if (count > 0) {
3138                         int i = 0;
3139                         SV *arg;
3140
3141                         SP -= count - 1;
3142                         arg = SP[i++];
3143
3144                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3145                             arg = SvRV(arg);
3146                         }
3147
3148                         if (SvTYPE(arg) == SVt_PVGV) {
3149                             IO *io = GvIO((GV *)arg);
3150
3151                             ++filter_has_file;
3152
3153                             if (io) {
3154                                 tryrsfp = IoIFP(io);
3155                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3156                                     /* reading from a child process doesn't
3157                                        nest -- when returning from reading
3158                                        the inner module, the outer one is
3159                                        unreadable (closed?)  I've tried to
3160                                        save the gv to manage the lifespan of
3161                                        the pipe, but this didn't help. XXX */
3162                                     filter_child_proc = (GV *)arg;
3163                                     (void)SvREFCNT_inc(filter_child_proc);
3164                                 }
3165                                 else {
3166                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3167                                         PerlIO_close(IoOFP(io));
3168                                     }
3169                                     IoIFP(io) = Nullfp;
3170                                     IoOFP(io) = Nullfp;
3171                                 }
3172                             }
3173
3174                             if (i < count) {
3175                                 arg = SP[i++];
3176                             }
3177                         }
3178
3179                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3180                             filter_sub = arg;
3181                             (void)SvREFCNT_inc(filter_sub);
3182
3183                             if (i < count) {
3184                                 filter_state = SP[i];
3185                                 (void)SvREFCNT_inc(filter_state);
3186                             }
3187
3188                             if (tryrsfp == 0) {
3189                                 tryrsfp = PerlIO_open("/dev/null",
3190                                                       PERL_SCRIPT_MODE);
3191                             }
3192                         }
3193                         SP--;
3194                     }
3195
3196                     PUTBACK;
3197                     FREETMPS;
3198                     LEAVE;
3199
3200                     if (tryrsfp) {
3201                         hook_sv = dirsv;
3202                         break;
3203                     }
3204
3205                     filter_has_file = 0;
3206                     if (filter_child_proc) {
3207                         SvREFCNT_dec(filter_child_proc);
3208                         filter_child_proc = 0;
3209                     }
3210                     if (filter_state) {
3211                         SvREFCNT_dec(filter_state);
3212                         filter_state = 0;
3213                     }
3214                     if (filter_sub) {
3215                         SvREFCNT_dec(filter_sub);
3216                         filter_sub = 0;
3217                     }
3218                 }
3219                 else {
3220                   if (!path_is_absolute(name)
3221 #ifdef MACOS_TRADITIONAL
3222                         /* We consider paths of the form :a:b ambiguous and interpret them first
3223                            as global then as local
3224                         */
3225                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3226 #endif
3227                   ) {
3228                     char *dir = SvPVx(dirsv, n_a);
3229 #ifdef MACOS_TRADITIONAL
3230                     char buf1[256];
3231                     char buf2[256];
3232
3233                     MacPerl_CanonDir(name, buf2, 1);
3234                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3235 #else
3236 #ifdef VMS
3237                     char *unixdir;
3238                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3239                         continue;
3240                     sv_setpv(namesv, unixdir);
3241                     sv_catpv(namesv, unixname);
3242 #else
3243                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3244 #endif
3245 #endif
3246                     TAINT_PROPER("require");
3247                     tryname = SvPVX(namesv);
3248                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3249                     if (tryrsfp) {
3250                         if (tryname[0] == '.' && tryname[1] == '/')
3251                             tryname += 2;
3252                         break;
3253                     }
3254                   }
3255                 }
3256             }
3257         }
3258     }
3259     SAVECOPFILE_FREE(&PL_compiling);
3260     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3261     SvREFCNT_dec(namesv);
3262     if (!tryrsfp) {
3263         if (PL_op->op_type == OP_REQUIRE) {
3264             char *msgstr = name;
3265             if (namesv) {                       /* did we lookup @INC? */
3266                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3267                 SV *dirmsgsv = NEWSV(0, 0);
3268                 AV *ar = GvAVn(PL_incgv);
3269                 I32 i;
3270                 sv_catpvn(msg, " in @INC", 8);
3271                 if (instr(SvPVX(msg), ".h "))
3272                     sv_catpv(msg, " (change .h to .ph maybe?)");
3273                 if (instr(SvPVX(msg), ".ph "))
3274                     sv_catpv(msg, " (did you run h2ph?)");
3275                 sv_catpv(msg, " (@INC contains:");
3276                 for (i = 0; i <= AvFILL(ar); i++) {
3277                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3278                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3279                     sv_catsv(msg, dirmsgsv);
3280                 }
3281                 sv_catpvn(msg, ")", 1);
3282                 SvREFCNT_dec(dirmsgsv);
3283                 msgstr = SvPV_nolen(msg);
3284             }
3285             DIE(aTHX_ "Can't locate %s", msgstr);
3286         }
3287
3288         RETPUSHUNDEF;
3289     }
3290     else
3291         SETERRNO(0, SS_NORMAL);
3292
3293     /* Assume success here to prevent recursive requirement. */
3294     len = strlen(name);
3295     /* Check whether a hook in @INC has already filled %INC */
3296     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3297         (void)hv_store(GvHVn(PL_incgv), name, len,
3298                        (hook_sv ? SvREFCNT_inc(hook_sv)
3299                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3300                        0 );
3301     }
3302
3303     ENTER;
3304     SAVETMPS;
3305     lex_start(sv_2mortal(newSVpvn("",0)));
3306     SAVEGENERICSV(PL_rsfp_filters);
3307     PL_rsfp_filters = Nullav;
3308
3309     PL_rsfp = tryrsfp;
3310     SAVEHINTS();
3311     PL_hints = 0;
3312     SAVESPTR(PL_compiling.cop_warnings);
3313     if (PL_dowarn & G_WARN_ALL_ON)
3314         PL_compiling.cop_warnings = pWARN_ALL ;
3315     else if (PL_dowarn & G_WARN_ALL_OFF)
3316         PL_compiling.cop_warnings = pWARN_NONE ;
3317     else if (PL_taint_warn)
3318         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3319     else
3320         PL_compiling.cop_warnings = pWARN_STD ;
3321     SAVESPTR(PL_compiling.cop_io);
3322     PL_compiling.cop_io = Nullsv;
3323
3324     if (filter_sub || filter_child_proc) {
3325         SV *datasv = filter_add(run_user_filter, Nullsv);
3326         IoLINES(datasv) = filter_has_file;
3327         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3328         IoTOP_GV(datasv) = (GV *)filter_state;
3329         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3330     }
3331
3332     /* switch to eval mode */
3333     push_return(PL_op->op_next);
3334     PUSHBLOCK(cx, CXt_EVAL, SP);
3335     PUSHEVAL(cx, name, Nullgv);
3336
3337     SAVECOPLINE(&PL_compiling);
3338     CopLINE_set(&PL_compiling, 0);
3339
3340     PUTBACK;
3341
3342     /* Store and reset encoding. */
3343     encoding = PL_encoding;
3344     PL_encoding = Nullsv;
3345
3346     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3347
3348     /* Restore encoding. */
3349     PL_encoding = encoding;
3350
3351     return op;
3352 }
3353
3354 PP(pp_dofile)
3355 {
3356     return pp_require();
3357 }
3358
3359 PP(pp_entereval)
3360 {
3361     dSP;
3362     register PERL_CONTEXT *cx;
3363     dPOPss;
3364     I32 gimme = GIMME_V, was = PL_sub_generation;
3365     char tbuf[TYPE_DIGITS(long) + 12];
3366     char *tmpbuf = tbuf;
3367     char *safestr;
3368     STRLEN len;
3369     OP *ret;
3370     CV* runcv;
3371     U32 seq;
3372
3373     if (!SvPV(sv,len))
3374         RETPUSHUNDEF;
3375     TAINT_PROPER("eval");
3376
3377     ENTER;
3378     lex_start(sv);
3379     SAVETMPS;
3380
3381     /* switch to eval mode */
3382
3383     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3384         SV *sv = sv_newmortal();
3385         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3386                        (unsigned long)++PL_evalseq,
3387                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3388         tmpbuf = SvPVX(sv);
3389     }
3390     else
3391         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3392     SAVECOPFILE_FREE(&PL_compiling);
3393     CopFILE_set(&PL_compiling, tmpbuf+2);
3394     SAVECOPLINE(&PL_compiling);
3395     CopLINE_set(&PL_compiling, 1);
3396     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3397        deleting the eval's FILEGV from the stash before gv_check() runs
3398        (i.e. before run-time proper). To work around the coredump that
3399        ensues, we always turn GvMULTI_on for any globals that were
3400        introduced within evals. See force_ident(). GSAR 96-10-12 */
3401     safestr = savepv(tmpbuf);
3402     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3403     SAVEHINTS();
3404     PL_hints = PL_op->op_targ;
3405     SAVESPTR(PL_compiling.cop_warnings);
3406     if (specialWARN(PL_curcop->cop_warnings))
3407         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3408     else {
3409         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3410         SAVEFREESV(PL_compiling.cop_warnings);
3411     }
3412     SAVESPTR(PL_compiling.cop_io);
3413     if (specialCopIO(PL_curcop->cop_io))
3414         PL_compiling.cop_io = PL_curcop->cop_io;
3415     else {
3416         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3417         SAVEFREESV(PL_compiling.cop_io);
3418     }
3419     /* special case: an eval '' executed within the DB package gets lexically
3420      * placed in the first non-DB CV rather than the current CV - this
3421      * allows the debugger to execute code, find lexicals etc, in the
3422      * scope of the code being debugged. Passing &seq gets find_runcv
3423      * to do the dirty work for us */
3424     runcv = find_runcv(&seq);
3425
3426     push_return(PL_op->op_next);
3427     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3428     PUSHEVAL(cx, 0, Nullgv);
3429
3430     /* prepare to compile string */
3431
3432     if (PERLDB_LINE && PL_curstash != PL_debstash)
3433         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3434     PUTBACK;
3435     ret = doeval(gimme, NULL, runcv, seq);
3436     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3437         && ret != PL_op->op_next) {     /* Successive compilation. */
3438         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3439     }
3440     return DOCATCH(ret);
3441 }
3442
3443 PP(pp_leaveeval)
3444 {
3445     dSP;
3446     register SV **mark;
3447     SV **newsp;
3448     PMOP *newpm;
3449     I32 gimme;
3450     register PERL_CONTEXT *cx;
3451     OP *retop;
3452     U8 save_flags = PL_op -> op_flags;
3453     I32 optype;
3454
3455     POPBLOCK(cx,newpm);
3456     POPEVAL(cx);
3457     retop = pop_return();
3458
3459     TAINT_NOT;
3460     if (gimme == G_VOID)
3461         MARK = newsp;
3462     else if (gimme == G_SCALAR) {
3463         MARK = newsp + 1;
3464         if (MARK <= SP) {
3465             if (SvFLAGS(TOPs) & SVs_TEMP)
3466                 *MARK = TOPs;
3467             else
3468                 *MARK = sv_mortalcopy(TOPs);
3469         }
3470         else {
3471             MEXTEND(mark,0);
3472             *MARK = &PL_sv_undef;
3473         }
3474         SP = MARK;
3475     }
3476     else {
3477         /* in case LEAVE wipes old return values */
3478         for (mark = newsp + 1; mark <= SP; mark++) {
3479             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3480                 *mark = sv_mortalcopy(*mark);
3481                 TAINT_NOT;      /* Each item is independent */
3482             }
3483         }
3484     }
3485     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3486
3487 #ifdef DEBUGGING
3488     assert(CvDEPTH(PL_compcv) == 1);
3489 #endif
3490     CvDEPTH(PL_compcv) = 0;
3491     lex_end();
3492
3493     if (optype == OP_REQUIRE &&
3494         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3495     {
3496         /* Unassume the success we assumed earlier. */
3497         SV *nsv = cx->blk_eval.old_namesv;
3498         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3499         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3500         /* die_where() did LEAVE, or we won't be here */
3501     }
3502     else {
3503         LEAVE;
3504         if (!(save_flags & OPf_SPECIAL))
3505             sv_setpv(ERRSV,"");
3506     }
3507
3508     RETURNOP(retop);
3509 }
3510
3511 PP(pp_entertry)
3512 {
3513     dSP;
3514     register PERL_CONTEXT *cx;
3515     I32 gimme = GIMME_V;
3516
3517     ENTER;
3518     SAVETMPS;
3519
3520     push_return(cLOGOP->op_other->op_next);
3521     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3522     PUSHEVAL(cx, 0, 0);
3523
3524     PL_in_eval = EVAL_INEVAL;
3525     sv_setpv(ERRSV,"");
3526     PUTBACK;
3527     return DOCATCH(PL_op->op_next);
3528 }
3529
3530 PP(pp_leavetry)
3531 {
3532     dSP;
3533     register SV **mark;
3534     SV **newsp;
3535     PMOP *newpm;
3536     OP* retop;
3537     I32 gimme;
3538     register PERL_CONTEXT *cx;
3539     I32 optype;
3540
3541     POPBLOCK(cx,newpm);
3542     POPEVAL(cx);
3543     retop = pop_return();
3544
3545     TAINT_NOT;
3546     if (gimme == G_VOID)
3547         SP = newsp;
3548     else if (gimme == G_SCALAR) {
3549         MARK = newsp + 1;
3550         if (MARK <= SP) {
3551             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3552                 *MARK = TOPs;
3553             else
3554                 *MARK = sv_mortalcopy(TOPs);
3555         }
3556         else {
3557             MEXTEND(mark,0);
3558             *MARK = &PL_sv_undef;
3559         }
3560         SP = MARK;
3561     }
3562     else {
3563         /* in case LEAVE wipes old return values */
3564         for (mark = newsp + 1; mark <= SP; mark++) {
3565             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3566                 *mark = sv_mortalcopy(*mark);
3567                 TAINT_NOT;      /* Each item is independent */
3568             }
3569         }
3570     }
3571     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3572
3573     LEAVE;
3574     sv_setpv(ERRSV,"");
3575     RETURNOP(retop);
3576 }
3577
3578 STATIC OP *
3579 S_doparseform(pTHX_ SV *sv)
3580 {
3581     STRLEN len;
3582     register char *s = SvPV_force(sv, len);
3583     register char *send = s + len;
3584     register char *base = Nullch;
3585     register I32 skipspaces = 0;
3586     bool noblank   = FALSE;
3587     bool repeat    = FALSE;
3588     bool postspace = FALSE;
3589     U32 *fops;
3590     register U32 *fpc;
3591     U32 *linepc = 0;
3592     register I32 arg;
3593     bool ischop;
3594     bool unchopnum = FALSE;
3595     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3596
3597     if (len == 0)
3598         Perl_croak(aTHX_ "Null picture in formline");
3599
3600     /* estimate the buffer size needed */
3601     for (base = s; s <= send; s++) {
3602         if (*s == '\n' || *s == '@' || *s == '^')
3603             maxops += 10;
3604     }
3605     s = base;
3606     base = Nullch;
3607
3608     New(804, fops, maxops, U32);
3609     fpc = fops;
3610
3611     if (s < send) {
3612         linepc = fpc;
3613         *fpc++ = FF_LINEMARK;
3614         noblank = repeat = FALSE;
3615         base = s;
3616     }
3617
3618     while (s <= send) {
3619         switch (*s++) {
3620         default:
3621             skipspaces = 0;
3622             continue;
3623
3624         case '~':
3625             if (*s == '~') {
3626                 repeat = TRUE;
3627                 *s = ' ';
3628             }
3629             noblank = TRUE;
3630             s[-1] = ' ';
3631             /* FALL THROUGH */
3632         case ' ': case '\t':
3633             skipspaces++;
3634             continue;
3635         case 0:
3636             if (s < send) {
3637                 skipspaces = 0;
3638                 continue;
3639             } /* else FALL THROUGH */
3640         case '\n':
3641             arg = s - base;
3642             skipspaces++;
3643             arg -= skipspaces;
3644             if (arg) {
3645                 if (postspace)
3646                     *fpc++ = FF_SPACE;
3647                 *fpc++ = FF_LITERAL;
3648                 *fpc++ = (U16)arg;
3649             }
3650             postspace = FALSE;
3651             if (s <= send)
3652                 skipspaces--;
3653             if (skipspaces) {
3654                 *fpc++ = FF_SKIP;
3655                 *fpc++ = (U16)skipspaces;
3656             }
3657             skipspaces = 0;
3658             if (s <= send)
3659                 *fpc++ = FF_NEWLINE;
3660             if (noblank) {
3661                 *fpc++ = FF_BLANK;
3662                 if (repeat)
3663                     arg = fpc - linepc + 1;
3664                 else
3665                     arg = 0;
3666                 *fpc++ = (U16)arg;
3667             }
3668             if (s < send) {
3669                 linepc = fpc;
3670                 *fpc++ = FF_LINEMARK;
3671                 noblank = repeat = FALSE;
3672                 base = s;
3673             }
3674             else
3675                 s++;
3676             continue;
3677
3678         case '@':
3679         case '^':
3680             ischop = s[-1] == '^';
3681
3682             if (postspace) {
3683                 *fpc++ = FF_SPACE;
3684                 postspace = FALSE;
3685             }
3686             arg = (s - base) - 1;
3687             if (arg) {
3688                 *fpc++ = FF_LITERAL;
3689                 *fpc++ = (U16)arg;
3690             }
3691
3692             base = s - 1;
3693             *fpc++ = FF_FETCH;
3694             if (*s == '*') {
3695                 s++;
3696                 *fpc++ = 2;  /* skip the @* or ^* */
3697                 if (ischop) {
3698                     *fpc++ = FF_LINESNGL;
3699                     *fpc++ = FF_CHOP;
3700                 } else
3701                     *fpc++ = FF_LINEGLOB;
3702             }
3703             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3704                 arg = ischop ? 512 : 0;
3705                 base = s - 1;
3706                 while (*s == '#')
3707                     s++;
3708                 if (*s == '.') {
3709                     char *f;
3710                     s++;
3711                     f = s;
3712                     while (*s == '#')
3713                         s++;
3714                     arg |= 256 + (s - f);
3715                 }
3716                 *fpc++ = s - base;              /* fieldsize for FETCH */
3717                 *fpc++ = FF_DECIMAL;
3718                 *fpc++ = (U16)arg;
3719                 unchopnum |= ! ischop;
3720             }
3721             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3722                 arg = ischop ? 512 : 0;
3723                 base = s - 1;
3724                 s++;                                /* skip the '0' first */
3725                 while (*s == '#')
3726                     s++;
3727                 if (*s == '.') {
3728                     char *f;
3729                     s++;
3730                     f = s;
3731                     while (*s == '#')
3732                         s++;
3733                     arg |= 256 + (s - f);
3734                 }
3735                 *fpc++ = s - base;                /* fieldsize for FETCH */
3736                 *fpc++ = FF_0DECIMAL;
3737                 *fpc++ = (U16)arg;
3738                 unchopnum |= ! ischop;
3739             }
3740             else {
3741                 I32 prespace = 0;
3742                 bool ismore = FALSE;
3743
3744                 if (*s == '>') {
3745                     while (*++s == '>') ;
3746                     prespace = FF_SPACE;
3747                 }
3748                 else if (*s == '|') {
3749                     while (*++s == '|') ;
3750                     prespace = FF_HALFSPACE;
3751                     postspace = TRUE;
3752                 }
3753                 else {
3754                     if (*s == '<')
3755                         while (*++s == '<') ;
3756                     postspace = TRUE;
3757                 }
3758                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3759                     s += 3;
3760                     ismore = TRUE;
3761                 }
3762                 *fpc++ = s - base;              /* fieldsize for FETCH */
3763
3764                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3765
3766                 if (prespace)
3767                     *fpc++ = (U16)prespace;
3768                 *fpc++ = FF_ITEM;
3769                 if (ismore)
3770                     *fpc++ = FF_MORE;
3771                 if (ischop)
3772                     *fpc++ = FF_CHOP;
3773             }
3774             base = s;
3775             skipspaces = 0;
3776             continue;
3777         }
3778     }
3779     *fpc++ = FF_END;
3780
3781     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3782     arg = fpc - fops;
3783     { /* need to jump to the next word */
3784         int z;
3785         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3786         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3787         s = SvPVX(sv) + SvCUR(sv) + z;
3788     }
3789     Copy(fops, s, arg, U32);
3790     Safefree(fops);
3791     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3792     SvCOMPILED_on(sv);
3793
3794     if (unchopnum && repeat)
3795         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3796     return 0;
3797 }
3798
3799
3800 STATIC bool
3801 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3802 {
3803     /* Can value be printed in fldsize chars, using %*.*f ? */
3804     NV pwr = 1;
3805     NV eps = 0.5;
3806     bool res = FALSE;
3807     int intsize = fldsize - (value < 0 ? 1 : 0);
3808
3809     if (frcsize & 256)
3810         intsize--;
3811     frcsize &= 255;
3812     intsize -= frcsize;
3813
3814     while (intsize--) pwr *= 10.0;
3815     while (frcsize--) eps /= 10.0;
3816
3817     if( value >= 0 ){
3818         if (value + eps >= pwr)
3819             res = TRUE;
3820     } else {
3821         if (value - eps <= -pwr)
3822             res = TRUE;
3823     }
3824     return res;
3825 }
3826
3827 static I32
3828 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3829 {
3830     SV *datasv = FILTER_DATA(idx);
3831     int filter_has_file = IoLINES(datasv);
3832     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3833     SV *filter_state = (SV *)IoTOP_GV(datasv);
3834     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3835     int len = 0;
3836
3837     /* I was having segfault trouble under Linux 2.2.5 after a
3838        parse error occured.  (Had to hack around it with a test
3839        for PL_error_count == 0.)  Solaris doesn't segfault --
3840        not sure where the trouble is yet.  XXX */
3841
3842     if (filter_has_file) {
3843         len = FILTER_READ(idx+1, buf_sv, maxlen);
3844     }
3845
3846     if (filter_sub && len >= 0) {
3847         dSP;
3848         int count;
3849
3850         ENTER;
3851         SAVE_DEFSV;
3852         SAVETMPS;
3853         EXTEND(SP, 2);
3854
3855         DEFSV = buf_sv;
3856         PUSHMARK(SP);
3857         PUSHs(sv_2mortal(newSViv(maxlen)));
3858         if (filter_state) {
3859             PUSHs(filter_state);
3860         }
3861         PUTBACK;
3862         count = call_sv(filter_sub, G_SCALAR);
3863         SPAGAIN;
3864
3865         if (count > 0) {
3866             SV *out = POPs;
3867             if (SvOK(out)) {
3868                 len = SvIV(out);
3869             }
3870         }
3871
3872         PUTBACK;
3873         FREETMPS;
3874         LEAVE;
3875     }
3876
3877     if (len <= 0) {
3878         IoLINES(datasv) = 0;
3879         if (filter_child_proc) {
3880             SvREFCNT_dec(filter_child_proc);
3881             IoFMT_GV(datasv) = Nullgv;
3882         }
3883         if (filter_state) {
3884             SvREFCNT_dec(filter_state);
3885             IoTOP_GV(datasv) = Nullgv;
3886         }
3887         if (filter_sub) {
3888             SvREFCNT_dec(filter_sub);
3889             IoBOTTOM_GV(datasv) = Nullgv;
3890         }
3891         filter_del(run_user_filter);
3892     }
3893
3894     return len;
3895 }
3896
3897 /* perhaps someone can come up with a better name for
3898    this?  it is not really "absolute", per se ... */
3899 static bool
3900 S_path_is_absolute(pTHX_ char *name)
3901 {
3902     if (PERL_FILE_IS_ABSOLUTE(name)
3903 #ifdef MACOS_TRADITIONAL
3904         || (*name == ':'))
3905 #else
3906         || (*name == '.' && (name[1] == '/' ||
3907                              (name[1] == '.' && name[2] == '/'))))
3908 #endif
3909     {
3910         return TRUE;
3911     }
3912     else
3913         return FALSE;
3914 }