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