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         while (items-- > 0)
 943             *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 944     }
 945     LEAVE;                                      /* exit inner scope */
 946
 947     /* All done yet? */
 948     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
 949
 950         (void)POPMARK;                          /* pop top */
 951         LEAVE;                                  /* exit outer scope */
 952         (void)POPMARK;                          /* pop src */
 953         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
 954         (void)POPMARK;                          /* pop dst */
 955         SP = PL_stack_base + POPMARK;           /* pop original mark */
 956         if (gimme == G_SCALAR) {
 957             if (PL_op->op_private & OPpGREP_LEX) {
 958                 SV* sv = sv_newmortal();
 959                 sv_setiv(sv, items);
 960                 PUSHs(sv);
 961             }
 962             else {
 963                 dTARGET;
 964                 XPUSHi(items);
 965             }
 966         }
 967         else if (gimme == G_ARRAY)
 968             SP += items;
 969         RETURN;
 970     }
 971     else {
 972         SV *src;
 973
 974         ENTER;                                  /* enter inner scope */
 975         SAVEVPTR(PL_curpm);
 976
 977         /* set $_ to the new source item */
 978         src = PL_stack_base[PL_markstack_ptr[-1]];
 979         SvTEMP_off(src);
 980         if (PL_op->op_private & OPpGREP_LEX)
 981             PAD_SVl(PL_op->op_targ) = src;
 982         else
 983             DEFSV = src;
 984
 985         RETURNOP(cLOGOP->op_other);
 986     }
 987 }
 988
 989 /* Range stuff. */
 990
 991 PP(pp_range)
 992 {
 993     if (GIMME == G_ARRAY)
 994         return NORMAL;
 995     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
 996         return cLOGOP->op_other;
 997     else
 998         return NORMAL;
 999 }
1000
1001 PP(pp_flip)
1002 {
1003     dSP;
1004
1005     if (GIMME == G_ARRAY) {
1006         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1007     }
1008     else {
1009         dTOPss;
1010         SV *targ = PAD_SV(PL_op->op_targ);
1011         int flip = 0;
1012
1013         if (PL_op->op_private & OPpFLIP_LINENUM) {
1014             if (GvIO(PL_last_in_gv)) {
1015                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1016             }
1017             else {
1018                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1019                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1020             }
1021         } else {
1022             flip = SvTRUE(sv);
1023         }
1024         if (flip) {
1025             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1026             if (PL_op->op_flags & OPf_SPECIAL) {
1027                 sv_setiv(targ, 1);
1028                 SETs(targ);
1029                 RETURN;
1030             }
1031             else {
1032                 sv_setiv(targ, 0);
1033                 SP--;
1034                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1035             }
1036         }
1037         sv_setpv(TARG, "");
1038         SETs(targ);
1039         RETURN;
1040     }
1041 }
1042
1043 /* This code tries to decide if "$left .. $right" should use the
1044    magical string increment, or if the range is numeric (we make
1045    an exception for .."0" [#18165]). AMS 20021031. */
1046
1047 #define RANGE_IS_NUMERIC(left,right) ( \
1048         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1049         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1050         (looks_like_number(left) && SvPOKp(left) && *SvPVX(left) != '0' && \
1051          looks_like_number(right)))
1052
1053 PP(pp_flop)
1054 {
1055     dSP;
1056
1057     if (GIMME == G_ARRAY) {
1058         dPOPPOPssrl;
1059         register I32 i, j;
1060         register SV *sv;
1061         I32 max;
1062
1063         if (SvGMAGICAL(left))
1064             mg_get(left);
1065         if (SvGMAGICAL(right))
1066             mg_get(right);
1067
1068         if (RANGE_IS_NUMERIC(left,right)) {
1069             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1070                 DIE(aTHX_ "Range iterator outside integer range");
1071             i = SvIV(left);
1072             max = SvIV(right);
1073             if (max >= i) {
1074                 j = max - i + 1;
1075                 EXTEND_MORTAL(j);
1076                 EXTEND(SP, j);
1077             }
1078             else
1079                 j = 0;
1080             while (j--) {
1081                 sv = sv_2mortal(newSViv(i++));
1082                 PUSHs(sv);
1083             }
1084         }
1085         else {
1086             SV *final = sv_mortalcopy(right);
1087             STRLEN len, n_a;
1088             char *tmps = SvPV(final, len);
1089
1090             sv = sv_mortalcopy(left);
1091             SvPV_force(sv,n_a);
1092             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1093                 XPUSHs(sv);
1094                 if (strEQ(SvPVX(sv),tmps))
1095                     break;
1096                 sv = sv_2mortal(newSVsv(sv));
1097                 sv_inc(sv);
1098             }
1099         }
1100     }
1101     else {
1102         dTOPss;
1103         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1104         int flop = 0;
1105         sv_inc(targ);
1106
1107         if (PL_op->op_private & OPpFLIP_LINENUM) {
1108             if (GvIO(PL_last_in_gv)) {
1109                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1110             }
1111             else {
1112                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1113                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1114             }
1115         }
1116         else {
1117             flop = SvTRUE(sv);
1118         }
1119
1120         if (flop) {
1121             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1122             sv_catpv(targ, "E0");
1123         }
1124         SETs(targ);
1125     }
1126
1127     RETURN;
1128 }
1129
1130 /* Control. */
1131
1132 static char *context_name[] = {
1133     "pseudo-block",
1134     "subroutine",
1135     "eval",
1136     "loop",
1137     "substitution",
1138     "block",
1139     "format"
1140 };
1141
1142 STATIC I32
1143 S_dopoptolabel(pTHX_ char *label)
1144 {
1145     register I32 i;
1146     register PERL_CONTEXT *cx;
1147
1148     for (i = cxstack_ix; i >= 0; i--) {
1149         cx = &cxstack[i];
1150         switch (CxTYPE(cx)) {
1151         case CXt_SUBST:
1152         case CXt_SUB:
1153         case CXt_FORMAT:
1154         case CXt_EVAL:
1155         case CXt_NULL:
1156             if (ckWARN(WARN_EXITING))
1157                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1158                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1159             if (CxTYPE(cx) == CXt_NULL)
1160                 return -1;
1161             break;
1162         case CXt_LOOP:
1163             if (!cx->blk_loop.label ||
1164               strNE(label, cx->blk_loop.label) ) {
1165                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1166                         (long)i, cx->blk_loop.label));
1167                 continue;
1168             }
1169             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1170             return i;
1171         }
1172     }
1173     return i;
1174 }
1175
1176 I32
1177 Perl_dowantarray(pTHX)
1178 {
1179     I32 gimme = block_gimme();
1180     return (gimme == G_VOID) ? G_SCALAR : gimme;
1181 }
1182
1183 I32
1184 Perl_block_gimme(pTHX)
1185 {
1186     I32 cxix;
1187
1188     cxix = dopoptosub(cxstack_ix);
1189     if (cxix < 0)
1190         return G_VOID;
1191
1192     switch (cxstack[cxix].blk_gimme) {
1193     case G_VOID:
1194         return G_VOID;
1195     case G_SCALAR:
1196         return G_SCALAR;
1197     case G_ARRAY:
1198         return G_ARRAY;
1199     default:
1200         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1201         /* NOTREACHED */
1202         return 0;
1203     }
1204 }
1205
1206 I32
1207 Perl_is_lvalue_sub(pTHX)
1208 {
1209     I32 cxix;
1210
1211     cxix = dopoptosub(cxstack_ix);
1212     assert(cxix >= 0);  /* We should only be called from inside subs */
1213
1214     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1215         return cxstack[cxix].blk_sub.lval;
1216     else
1217         return 0;
1218 }
1219
1220 STATIC I32
1221 S_dopoptosub(pTHX_ I32 startingblock)
1222 {
1223     return dopoptosub_at(cxstack, startingblock);
1224 }
1225
1226 STATIC I32
1227 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1228 {
1229     I32 i;
1230     register PERL_CONTEXT *cx;
1231     for (i = startingblock; i >= 0; i--) {
1232         cx = &cxstk[i];
1233         switch (CxTYPE(cx)) {
1234         default:
1235             continue;
1236         case CXt_EVAL:
1237         case CXt_SUB:
1238         case CXt_FORMAT:
1239             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1240             return i;
1241         }
1242     }
1243     return i;
1244 }
1245
1246 STATIC I32
1247 S_dopoptoeval(pTHX_ I32 startingblock)
1248 {
1249     I32 i;
1250     register PERL_CONTEXT *cx;
1251     for (i = startingblock; i >= 0; i--) {
1252         cx = &cxstack[i];
1253         switch (CxTYPE(cx)) {
1254         default:
1255             continue;
1256         case CXt_EVAL:
1257             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1258             return i;
1259         }
1260     }
1261     return i;
1262 }
1263
1264 STATIC I32
1265 S_dopoptoloop(pTHX_ I32 startingblock)
1266 {
1267     I32 i;
1268     register PERL_CONTEXT *cx;
1269     for (i = startingblock; i >= 0; i--) {
1270         cx = &cxstack[i];
1271         switch (CxTYPE(cx)) {
1272         case CXt_SUBST:
1273         case CXt_SUB:
1274         case CXt_FORMAT:
1275         case CXt_EVAL:
1276         case CXt_NULL:
1277             if (ckWARN(WARN_EXITING))
1278                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1279                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1280             if ((CxTYPE(cx)) == CXt_NULL)
1281                 return -1;
1282             break;
1283         case CXt_LOOP:
1284             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1285             return i;
1286         }
1287     }
1288     return i;
1289 }
1290
1291 void
1292 Perl_dounwind(pTHX_ I32 cxix)
1293 {
1294     register PERL_CONTEXT *cx;
1295     I32 optype;
1296
1297     while (cxstack_ix > cxix) {
1298         SV *sv;
1299         cx = &cxstack[cxstack_ix];
1300         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1301                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1302         /* Note: we don't need to restore the base context info till the end. */
1303         switch (CxTYPE(cx)) {
1304         case CXt_SUBST:
1305             POPSUBST(cx);
1306             continue;  /* not break */
1307         case CXt_SUB:
1308             POPSUB(cx,sv);
1309             LEAVESUB(sv);
1310             break;
1311         case CXt_EVAL:
1312             POPEVAL(cx);
1313             break;
1314         case CXt_LOOP:
1315             POPLOOP(cx);
1316             break;
1317         case CXt_NULL:
1318             break;
1319         case CXt_FORMAT:
1320             POPFORMAT(cx);
1321             break;
1322         }
1323         cxstack_ix--;
1324     }
1325 }
1326
1327 void
1328 Perl_qerror(pTHX_ SV *err)
1329 {
1330     if (PL_in_eval)
1331         sv_catsv(ERRSV, err);
1332     else if (PL_errors)
1333         sv_catsv(PL_errors, err);
1334     else
1335         Perl_warn(aTHX_ "%"SVf, err);
1336     ++PL_error_count;
1337 }
1338
1339 OP *
1340 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1341 {
1342     STRLEN n_a;
1343
1344     if (PL_in_eval) {
1345         I32 cxix;
1346         register PERL_CONTEXT *cx;
1347         I32 gimme;
1348         SV **newsp;
1349
1350         if (message) {
1351             if (PL_in_eval & EVAL_KEEPERR) {
1352                 static char prefix[] = "\t(in cleanup) ";
1353                 SV *err = ERRSV;
1354                 char *e = Nullch;
1355                 if (!SvPOK(err))
1356                     sv_setpv(err,"");
1357                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1358                     e = SvPV(err, n_a);
1359                     e += n_a - msglen;
1360                     if (*e != *message || strNE(e,message))
1361                         e = Nullch;
1362                 }
1363                 if (!e) {
1364                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1365                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1366                     sv_catpvn(err, message, msglen);
1367                     if (ckWARN(WARN_MISC)) {
1368                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1369                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1370                     }
1371                 }
1372             }
1373             else {
1374                 sv_setpvn(ERRSV, message, msglen);
1375             }
1376         }
1377
1378         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1379                && PL_curstackinfo->si_prev)
1380         {
1381             dounwind(-1);
1382             POPSTACK;
1383         }
1384
1385         if (cxix >= 0) {
1386             I32 optype;
1387
1388             if (cxix < cxstack_ix)
1389                 dounwind(cxix);
1390
1391             POPBLOCK(cx,PL_curpm);
1392             if (CxTYPE(cx) != CXt_EVAL) {
1393                 if (!message)
1394                     message = SvPVx(ERRSV, msglen);
1395                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1396                 PerlIO_write(Perl_error_log, message, msglen);
1397                 my_exit(1);
1398             }
1399             POPEVAL(cx);
1400
1401             if (gimme == G_SCALAR)
1402                 *++newsp = &PL_sv_undef;
1403             PL_stack_sp = newsp;
1404
1405             LEAVE;
1406
1407             /* LEAVE could clobber PL_curcop (see save_re_context())
1408              * XXX it might be better to find a way to avoid messing with
1409              * PL_curcop in save_re_context() instead, but this is a more
1410              * minimal fix --GSAR */
1411             PL_curcop = cx->blk_oldcop;
1412
1413             if (optype == OP_REQUIRE) {
1414                 char* msg = SvPVx(ERRSV, n_a);
1415                SV *nsv = cx->blk_eval.old_namesv;
1416                (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1417                                &PL_sv_undef, 0);
1418                 DIE(aTHX_ "%sCompilation failed in require",
1419                     *msg ? msg : "Unknown error\n");
1420             }
1421             return pop_return();
1422         }
1423     }
1424     if (!message)
1425         message = SvPVx(ERRSV, msglen);
1426
1427     write_to_stderr(message, msglen);
1428     my_failure_exit();
1429     /* NOTREACHED */
1430     return 0;
1431 }
1432
1433 PP(pp_xor)
1434 {
1435     dSP; dPOPTOPssrl;
1436     if (SvTRUE(left) != SvTRUE(right))
1437         RETSETYES;
1438     else
1439         RETSETNO;
1440 }
1441
1442 PP(pp_andassign)
1443 {
1444     dSP;
1445     if (!SvTRUE(TOPs))
1446         RETURN;
1447     else
1448         RETURNOP(cLOGOP->op_other);
1449 }
1450
1451 PP(pp_orassign)
1452 {
1453     dSP;
1454     if (SvTRUE(TOPs))
1455         RETURN;
1456     else
1457         RETURNOP(cLOGOP->op_other);
1458 }
1459
1460 PP(pp_dorassign)
1461 {
1462     dSP;
1463     register SV* sv;
1464
1465     sv = TOPs;
1466     if (!sv || !SvANY(sv)) {
1467         RETURNOP(cLOGOP->op_other);
1468     }
1469
1470     switch (SvTYPE(sv)) {
1471     case SVt_PVAV:
1472         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1473             RETURN;
1474         break;
1475     case SVt_PVHV:
1476         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1477             RETURN;
1478         break;
1479     case SVt_PVCV:
1480         if (CvROOT(sv) || CvXSUB(sv))
1481             RETURN;
1482         break;
1483     default:
1484         if (SvGMAGICAL(sv))
1485             mg_get(sv);
1486         if (SvOK(sv))
1487             RETURN;
1488     }
1489
1490     RETURNOP(cLOGOP->op_other);
1491 }
1492
1493 PP(pp_caller)
1494 {
1495     dSP;
1496     register I32 cxix = dopoptosub(cxstack_ix);
1497     register PERL_CONTEXT *cx;
1498     register PERL_CONTEXT *ccstack = cxstack;
1499     PERL_SI *top_si = PL_curstackinfo;
1500     I32 dbcxix;
1501     I32 gimme;
1502     char *stashname;
1503     SV *sv;
1504     I32 count = 0;
1505
1506     if (MAXARG)
1507         count = POPi;
1508
1509     for (;;) {
1510         /* we may be in a higher stacklevel, so dig down deeper */
1511         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1512             top_si = top_si->si_prev;
1513             ccstack = top_si->si_cxstack;
1514             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1515         }
1516         if (cxix < 0) {
1517             if (GIMME != G_ARRAY) {
1518                 EXTEND(SP, 1);
1519                 RETPUSHUNDEF;
1520             }
1521             RETURN;
1522         }
1523         if (PL_DBsub && cxix >= 0 &&
1524                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1525             count++;
1526         if (!count--)
1527             break;
1528         cxix = dopoptosub_at(ccstack, cxix - 1);
1529     }
1530
1531     cx = &ccstack[cxix];
1532     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1533         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1534         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1535            field below is defined for any cx. */
1536         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1537             cx = &ccstack[dbcxix];
1538     }
1539
1540     stashname = CopSTASHPV(cx->blk_oldcop);
1541     if (GIMME != G_ARRAY) {
1542         EXTEND(SP, 1);
1543         if (!stashname)
1544             PUSHs(&PL_sv_undef);
1545         else {
1546             dTARGET;
1547             sv_setpv(TARG, stashname);
1548             PUSHs(TARG);
1549         }
1550         RETURN;
1551     }
1552
1553     EXTEND(SP, 10);
1554
1555     if (!stashname)
1556         PUSHs(&PL_sv_undef);
1557     else
1558         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1559     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1560     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1561     if (!MAXARG)
1562         RETURN;
1563     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1565         /* So is ccstack[dbcxix]. */
1566         if (isGV(cvgv)) {
1567             sv = NEWSV(49, 0);
1568             gv_efullname3(sv, cvgv, Nullch);
1569             PUSHs(sv_2mortal(sv));
1570             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1571         }
1572         else {
1573             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1574             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1575         }
1576     }
1577     else {
1578         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1579         PUSHs(sv_2mortal(newSViv(0)));
1580     }
1581     gimme = (I32)cx->blk_gimme;
1582     if (gimme == G_VOID)
1583         PUSHs(&PL_sv_undef);
1584     else
1585         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1586     if (CxTYPE(cx) == CXt_EVAL) {
1587         /* eval STRING */
1588         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1589             PUSHs(cx->blk_eval.cur_text);
1590             PUSHs(&PL_sv_no);
1591         }
1592         /* require */
1593         else if (cx->blk_eval.old_namesv) {
1594             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1595             PUSHs(&PL_sv_yes);
1596         }
1597         /* eval BLOCK (try blocks have old_namesv == 0) */
1598         else {
1599             PUSHs(&PL_sv_undef);
1600             PUSHs(&PL_sv_undef);
1601         }
1602     }
1603     else {
1604         PUSHs(&PL_sv_undef);
1605         PUSHs(&PL_sv_undef);
1606     }
1607     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1608         && CopSTASH_eq(PL_curcop, PL_debstash))
1609     {
1610         AV *ary = cx->blk_sub.argarray;
1611         int off = AvARRAY(ary) - AvALLOC(ary);
1612
1613         if (!PL_dbargs) {
1614             GV* tmpgv;
1615             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1616                                 SVt_PVAV)));
1617             GvMULTI_on(tmpgv);
1618             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1619         }
1620
1621         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1622             av_extend(PL_dbargs, AvFILLp(ary) + off);
1623         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1624         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1625     }
1626     /* XXX only hints propagated via op_private are currently
1627      * visible (others are not easily accessible, since they
1628      * use the global PL_hints) */
1629     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1630                              HINT_PRIVATE_MASK)));
1631     {
1632         SV * mask ;
1633         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1634
1635         if  (old_warnings == pWARN_NONE ||
1636                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1637             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1638         else if (old_warnings == pWARN_ALL ||
1639                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1640             /* Get the bit mask for $warnings::Bits{all}, because
1641              * it could have been extended by warnings::register */
1642             SV **bits_all;
1643             HV *bits = get_hv("warnings::Bits", FALSE);
1644             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1645                 mask = newSVsv(*bits_all);
1646             }
1647             else {
1648                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1649             }
1650         }
1651         else
1652             mask = newSVsv(old_warnings);
1653         PUSHs(sv_2mortal(mask));
1654     }
1655     RETURN;
1656 }
1657
1658 PP(pp_reset)
1659 {
1660     dSP;
1661     char *tmps;
1662     STRLEN n_a;
1663
1664     if (MAXARG < 1)
1665         tmps = "";
1666     else
1667         tmps = POPpx;
1668     sv_reset(tmps, CopSTASH(PL_curcop));
1669     PUSHs(&PL_sv_yes);
1670     RETURN;
1671 }
1672
1673 PP(pp_lineseq)
1674 {
1675     return NORMAL;
1676 }
1677
1678 /* like pp_nextstate, but used instead when the debugger is active */
1679
1680 PP(pp_dbstate)
1681 {
1682     PL_curcop = (COP*)PL_op;
1683     TAINT_NOT;          /* Each statement is presumed innocent */
1684     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1685     FREETMPS;
1686
1687     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1688             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1689     {
1690         dSP;
1691         register CV *cv;
1692         register PERL_CONTEXT *cx;
1693         I32 gimme = G_ARRAY;
1694         U8 hasargs;
1695         GV *gv;
1696
1697         gv = PL_DBgv;
1698         cv = GvCV(gv);
1699         if (!cv)
1700             DIE(aTHX_ "No DB::DB routine defined");
1701
1702         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1703             /* don't do recursive DB::DB call */
1704             return NORMAL;
1705
1706         ENTER;
1707         SAVETMPS;
1708
1709         SAVEI32(PL_debug);
1710         SAVESTACK_POS();
1711         PL_debug = 0;
1712         hasargs = 0;
1713         SPAGAIN;
1714
1715         push_return(PL_op->op_next);
1716         PUSHBLOCK(cx, CXt_SUB, SP);
1717         PUSHSUB_DB(cx);
1718         CvDEPTH(cv)++;
1719         PAD_SET_CUR(CvPADLIST(cv),1);
1720         RETURNOP(CvSTART(cv));
1721     }
1722     else
1723         return NORMAL;
1724 }
1725
1726 PP(pp_scope)
1727 {
1728     return NORMAL;
1729 }
1730
1731 PP(pp_enteriter)
1732 {
1733     dSP; dMARK;
1734     register PERL_CONTEXT *cx;
1735     I32 gimme = GIMME_V;
1736     SV **svp;
1737     U32 cxtype = CXt_LOOP;
1738 #ifdef USE_ITHREADS
1739     void *iterdata;
1740 #endif
1741
1742     ENTER;
1743     SAVETMPS;
1744
1745     if (PL_op->op_targ) {
1746         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1747             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1748             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1749                     SVs_PADSTALE, SVs_PADSTALE);
1750         }
1751 #ifndef USE_ITHREADS
1752         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1753         SAVESPTR(*svp);
1754 #else
1755         SAVEPADSV(PL_op->op_targ);
1756         iterdata = INT2PTR(void*, PL_op->op_targ);
1757         cxtype |= CXp_PADVAR;
1758 #endif
1759     }
1760     else {
1761         GV *gv = (GV*)POPs;
1762         svp = &GvSV(gv);                        /* symbol table variable */
1763         SAVEGENERICSV(*svp);
1764         *svp = NEWSV(0,0);
1765 #ifdef USE_ITHREADS
1766         iterdata = (void*)gv;
1767 #endif
1768     }
1769
1770     ENTER;
1771
1772     PUSHBLOCK(cx, cxtype, SP);
1773 #ifdef USE_ITHREADS
1774     PUSHLOOP(cx, iterdata, MARK);
1775 #else
1776     PUSHLOOP(cx, svp, MARK);
1777 #endif
1778     if (PL_op->op_flags & OPf_STACKED) {
1779         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1780         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1781             dPOPss;
1782             if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
1783                  if (SvNV(sv) < IV_MIN ||
1784                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1785                      DIE(aTHX_ "Range iterator outside integer range");
1786                  cx->blk_loop.iterix = SvIV(sv);
1787                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1788             }
1789             else
1790                 cx->blk_loop.iterlval = newSVsv(sv);
1791         }
1792     }
1793     else {
1794         cx->blk_loop.iterary = PL_curstack;
1795         AvFILLp(PL_curstack) = SP - PL_stack_base;
1796         cx->blk_loop.iterix = MARK - PL_stack_base;
1797     }
1798
1799     RETURN;
1800 }
1801
1802 PP(pp_enterloop)
1803 {
1804     dSP;
1805     register PERL_CONTEXT *cx;
1806     I32 gimme = GIMME_V;
1807
1808     ENTER;
1809     SAVETMPS;
1810     ENTER;
1811
1812     PUSHBLOCK(cx, CXt_LOOP, SP);
1813     PUSHLOOP(cx, 0, SP);
1814
1815     RETURN;
1816 }
1817
1818 PP(pp_leaveloop)
1819 {
1820     dSP;
1821     register PERL_CONTEXT *cx;
1822     I32 gimme;
1823     SV **newsp;
1824     PMOP *newpm;
1825     SV **mark;
1826
1827     POPBLOCK(cx,newpm);
1828     mark = newsp;
1829     newsp = PL_stack_base + cx->blk_loop.resetsp;
1830
1831     TAINT_NOT;
1832     if (gimme == G_VOID)
1833         ; /* do nothing */
1834     else if (gimme == G_SCALAR) {
1835         if (mark < SP)
1836             *++newsp = sv_mortalcopy(*SP);
1837         else
1838             *++newsp = &PL_sv_undef;
1839     }
1840     else {
1841         while (mark < SP) {
1842             *++newsp = sv_mortalcopy(*++mark);
1843             TAINT_NOT;          /* Each item is independent */
1844         }
1845     }
1846     SP = newsp;
1847     PUTBACK;
1848
1849     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1850     PL_curpm = newpm;   /* ... and pop $1 et al */
1851
1852     LEAVE;
1853     LEAVE;
1854
1855     return NORMAL;
1856 }
1857
1858 PP(pp_return)
1859 {
1860     dSP; dMARK;
1861     I32 cxix;
1862     register PERL_CONTEXT *cx;
1863     bool popsub2 = FALSE;
1864     bool clear_errsv = FALSE;
1865     I32 gimme;
1866     SV **newsp;
1867     PMOP *newpm;
1868     I32 optype = 0;
1869     SV *sv;
1870
1871     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1872         if (cxstack_ix == PL_sortcxix
1873             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1874         {
1875             if (cxstack_ix > PL_sortcxix)
1876                 dounwind(PL_sortcxix);
1877             AvARRAY(PL_curstack)[1] = *SP;
1878             PL_stack_sp = PL_stack_base + 1;
1879             return 0;
1880         }
1881     }
1882
1883     cxix = dopoptosub(cxstack_ix);
1884     if (cxix < 0)
1885         DIE(aTHX_ "Can't return outside a subroutine");
1886     if (cxix < cxstack_ix)
1887         dounwind(cxix);
1888
1889     POPBLOCK(cx,newpm);
1890     switch (CxTYPE(cx)) {
1891     case CXt_SUB:
1892         popsub2 = TRUE;
1893         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1894         break;
1895     case CXt_EVAL:
1896         if (!(PL_in_eval & EVAL_KEEPERR))
1897             clear_errsv = TRUE;
1898         POPEVAL(cx);
1899         if (CxTRYBLOCK(cx))
1900             break;
1901         lex_end();
1902         if (optype == OP_REQUIRE &&
1903             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1904         {
1905             /* Unassume the success we assumed earlier. */
1906             SV *nsv = cx->blk_eval.old_namesv;
1907             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1908             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1909         }
1910         break;
1911     case CXt_FORMAT:
1912         POPFORMAT(cx);
1913         break;
1914     default:
1915         DIE(aTHX_ "panic: return");
1916     }
1917
1918     TAINT_NOT;
1919     if (gimme == G_SCALAR) {
1920         if (MARK < SP) {
1921             if (popsub2) {
1922                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1923                     if (SvTEMP(TOPs)) {
1924                         *++newsp = SvREFCNT_inc(*SP);
1925                         FREETMPS;
1926                         sv_2mortal(*newsp);
1927                     }
1928                     else {
1929                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1930                         FREETMPS;
1931                         *++newsp = sv_mortalcopy(sv);
1932                         SvREFCNT_dec(sv);
1933                     }
1934                 }
1935                 else
1936                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1937             }
1938             else
1939                 *++newsp = sv_mortalcopy(*SP);
1940         }
1941         else
1942             *++newsp = &PL_sv_undef;
1943     }
1944     else if (gimme == G_ARRAY) {
1945         while (++MARK <= SP) {
1946             *++newsp = (popsub2 && SvTEMP(*MARK))
1947                         ? *MARK : sv_mortalcopy(*MARK);
1948             TAINT_NOT;          /* Each item is independent */
1949         }
1950     }
1951     PL_stack_sp = newsp;
1952
1953     LEAVE;
1954     /* Stack values are safe: */
1955     if (popsub2) {
1956         cxstack_ix--;
1957         POPSUB(cx,sv);  /* release CV and @_ ... */
1958     }
1959     else
1960         sv = Nullsv;
1961     PL_curpm = newpm;   /* ... and pop $1 et al */
1962
1963     LEAVESUB(sv);
1964     if (clear_errsv)
1965         sv_setpv(ERRSV,"");
1966     return pop_return();
1967 }
1968
1969 PP(pp_last)
1970 {
1971     dSP;
1972     I32 cxix;
1973     register PERL_CONTEXT *cx;
1974     I32 pop2 = 0;
1975     I32 gimme;
1976     I32 optype;
1977     OP *nextop;
1978     SV **newsp;
1979     PMOP *newpm;
1980     SV **mark;
1981     SV *sv = Nullsv;
1982
1983     if (PL_op->op_flags & OPf_SPECIAL) {
1984         cxix = dopoptoloop(cxstack_ix);
1985         if (cxix < 0)
1986             DIE(aTHX_ "Can't \"last\" outside a loop block");
1987     }
1988     else {
1989         cxix = dopoptolabel(cPVOP->op_pv);
1990         if (cxix < 0)
1991             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1992     }
1993     if (cxix < cxstack_ix)
1994         dounwind(cxix);
1995
1996     POPBLOCK(cx,newpm);
1997     cxstack_ix++; /* temporarily protect top context */
1998     mark = newsp;
1999     switch (CxTYPE(cx)) {
2000     case CXt_LOOP:
2001         pop2 = CXt_LOOP;
2002         newsp = PL_stack_base + cx->blk_loop.resetsp;
2003         nextop = cx->blk_loop.last_op->op_next;
2004         break;
2005     case CXt_SUB:
2006         pop2 = CXt_SUB;
2007         nextop = pop_return();
2008         break;
2009     case CXt_EVAL:
2010         POPEVAL(cx);
2011         nextop = pop_return();
2012         break;
2013     case CXt_FORMAT:
2014         POPFORMAT(cx);
2015         nextop = pop_return();
2016         break;
2017     default:
2018         DIE(aTHX_ "panic: last");
2019     }
2020
2021     TAINT_NOT;
2022     if (gimme == G_SCALAR) {
2023         if (MARK < SP)
2024             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2025                         ? *SP : sv_mortalcopy(*SP);
2026         else
2027             *++newsp = &PL_sv_undef;
2028     }
2029     else if (gimme == G_ARRAY) {
2030         while (++MARK <= SP) {
2031             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2032                         ? *MARK : sv_mortalcopy(*MARK);
2033             TAINT_NOT;          /* Each item is independent */
2034         }
2035     }
2036     SP = newsp;
2037     PUTBACK;
2038
2039     LEAVE;
2040     cxstack_ix--;
2041     /* Stack values are safe: */
2042     switch (pop2) {
2043     case CXt_LOOP:
2044         POPLOOP(cx);    /* release loop vars ... */
2045         LEAVE;
2046         break;
2047     case CXt_SUB:
2048         POPSUB(cx,sv);  /* release CV and @_ ... */
2049         break;
2050     }
2051     PL_curpm = newpm;   /* ... and pop $1 et al */
2052
2053     LEAVESUB(sv);
2054     return nextop;
2055 }
2056
2057 PP(pp_next)
2058 {
2059     I32 cxix;
2060     register PERL_CONTEXT *cx;
2061     I32 inner;
2062
2063     if (PL_op->op_flags & OPf_SPECIAL) {
2064         cxix = dopoptoloop(cxstack_ix);
2065         if (cxix < 0)
2066             DIE(aTHX_ "Can't \"next\" outside a loop block");
2067     }
2068     else {
2069         cxix = dopoptolabel(cPVOP->op_pv);
2070         if (cxix < 0)
2071             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2072     }
2073     if (cxix < cxstack_ix)
2074         dounwind(cxix);
2075
2076     /* clear off anything above the scope we're re-entering, but
2077      * save the rest until after a possible continue block */
2078     inner = PL_scopestack_ix;
2079     TOPBLOCK(cx);
2080     if (PL_scopestack_ix < inner)
2081         leave_scope(PL_scopestack[PL_scopestack_ix]);
2082     return cx->blk_loop.next_op;
2083 }
2084
2085 PP(pp_redo)
2086 {
2087     I32 cxix;
2088     register PERL_CONTEXT *cx;
2089     I32 oldsave;
2090
2091     if (PL_op->op_flags & OPf_SPECIAL) {
2092         cxix = dopoptoloop(cxstack_ix);
2093         if (cxix < 0)
2094             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2095     }
2096     else {
2097         cxix = dopoptolabel(cPVOP->op_pv);
2098         if (cxix < 0)
2099             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2100     }
2101     if (cxix < cxstack_ix)
2102         dounwind(cxix);
2103
2104     TOPBLOCK(cx);
2105     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2106     LEAVE_SCOPE(oldsave);
2107     return cx->blk_loop.redo_op;
2108 }
2109
2110 STATIC OP *
2111 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2112 {
2113     OP *kid = Nullop;
2114     OP **ops = opstack;
2115     static char too_deep[] = "Target of goto is too deeply nested";
2116
2117     if (ops >= oplimit)
2118         Perl_croak(aTHX_ too_deep);
2119     if (o->op_type == OP_LEAVE ||
2120         o->op_type == OP_SCOPE ||
2121         o->op_type == OP_LEAVELOOP ||
2122         o->op_type == OP_LEAVESUB ||
2123         o->op_type == OP_LEAVETRY)
2124     {
2125         *ops++ = cUNOPo->op_first;
2126         if (ops >= oplimit)
2127             Perl_croak(aTHX_ too_deep);
2128     }
2129     *ops = 0;
2130     if (o->op_flags & OPf_KIDS) {
2131         /* First try all the kids at this level, since that's likeliest. */
2132         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2133             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2134                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2135                 return kid;
2136         }
2137         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2138             if (kid == PL_lastgotoprobe)
2139                 continue;
2140             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2141                 if (ops == opstack)
2142                     *ops++ = kid;
2143                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2144                          ops[-1]->op_type == OP_DBSTATE)
2145                     ops[-1] = kid;
2146                 else
2147                     *ops++ = kid;
2148             }
2149             if ((o = dofindlabel(kid, label, ops, oplimit)))
2150                 return o;
2151         }
2152     }
2153     *ops = 0;
2154     return 0;
2155 }
2156
2157 PP(pp_dump)
2158 {
2159     return pp_goto();
2160     /*NOTREACHED*/
2161 }
2162
2163 PP(pp_goto)
2164 {
2165     dSP;
2166     OP *retop = 0;
2167     I32 ix;
2168     register PERL_CONTEXT *cx;
2169 #define GOTO_DEPTH 64
2170     OP *enterops[GOTO_DEPTH];
2171     char *label;
2172     int do_dump = (PL_op->op_type == OP_DUMP);
2173     static char must_have_label[] = "goto must have label";
2174
2175     label = 0;
2176     if (PL_op->op_flags & OPf_STACKED) {
2177         SV *sv = POPs;
2178         STRLEN n_a;
2179
2180         /* This egregious kludge implements goto &subroutine */
2181         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2182             I32 cxix;
2183             register PERL_CONTEXT *cx;
2184             CV* cv = (CV*)SvRV(sv);
2185             SV** mark;
2186             I32 items = 0;
2187             I32 oldsave;
2188
2189         retry:
2190             if (!CvROOT(cv) && !CvXSUB(cv)) {
2191                 GV *gv = CvGV(cv);
2192                 GV *autogv;
2193                 if (gv) {
2194                     SV *tmpstr;
2195                     /* autoloaded stub? */
2196                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2197                         goto retry;
2198                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2199                                           GvNAMELEN(gv), FALSE);
2200                     if (autogv && (cv = GvCV(autogv)))
2201                         goto retry;
2202                     tmpstr = sv_newmortal();
2203                     gv_efullname3(tmpstr, gv, Nullch);
2204                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2205                 }
2206                 DIE(aTHX_ "Goto undefined subroutine");
2207             }
2208
2209             /* First do some returnish stuff. */
2210             SvREFCNT_inc(cv); /* avoid premature free during unwind */
2211             FREETMPS;
2212             cxix = dopoptosub(cxstack_ix);
2213             if (cxix < 0)
2214                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2215             if (cxix < cxstack_ix)
2216                 dounwind(cxix);
2217             TOPBLOCK(cx);
2218             if (CxREALEVAL(cx))
2219                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2220             mark = PL_stack_sp;
2221             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2222                 /* put @_ back onto stack */
2223                 AV* av = cx->blk_sub.argarray;
2224
2225                 items = AvFILLp(av) + 1;
2226                 PL_stack_sp++;
2227                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2228                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2229                 PL_stack_sp += items;
2230                 SvREFCNT_dec(GvAV(PL_defgv));
2231                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2232                 /* abandon @_ if it got reified */
2233                 if (AvREAL(av)) {
2234                     (void)sv_2mortal((SV*)av);  /* delay until return */
2235                     av = newAV();
2236                     av_extend(av, items-1);
2237                     AvFLAGS(av) = AVf_REIFY;
2238                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2239                 }
2240                 else
2241                     CLEAR_ARGARRAY(av);
2242             }
2243             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2244                 AV* av;
2245                 av = GvAV(PL_defgv);
2246                 items = AvFILLp(av) + 1;
2247                 PL_stack_sp++;
2248                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2249                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2250                 PL_stack_sp += items;
2251             }
2252             if (CxTYPE(cx) == CXt_SUB &&
2253                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2254                 SvREFCNT_dec(cx->blk_sub.cv);
2255             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2256             LEAVE_SCOPE(oldsave);
2257
2258             /* Now do some callish stuff. */
2259             SAVETMPS;
2260             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2261             if (CvXSUB(cv)) {
2262 #ifdef PERL_XSUB_OLDSTYLE
2263                 if (CvOLDSTYLE(cv)) {
2264                     I32 (*fp3)(int,int,int);
2265                     while (SP > mark) {
2266                         SP[1] = SP[0];
2267                         SP--;
2268                     }
2269                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2270                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2271                                    mark - PL_stack_base + 1,
2272                                    items);
2273                     SP = PL_stack_base + items;
2274                 }
2275                 else
2276 #endif /* PERL_XSUB_OLDSTYLE */
2277                 {
2278                     SV **newsp;
2279                     I32 gimme;
2280
2281                     PL_stack_sp--;              /* There is no cv arg. */
2282                     /* Push a mark for the start of arglist */
2283                     PUSHMARK(mark);
2284                     (void)(*CvXSUB(cv))(aTHX_ cv);
2285                     /* Pop the current context like a decent sub should */
2286                     POPBLOCK(cx, PL_curpm);
2287                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2288                 }
2289                 LEAVE;
2290                 return pop_return();
2291             }
2292             else {
2293                 AV* padlist = CvPADLIST(cv);
2294                 if (CxTYPE(cx) == CXt_EVAL) {
2295                     PL_in_eval = cx->blk_eval.old_in_eval;
2296                     PL_eval_root = cx->blk_eval.old_eval_root;
2297                     cx->cx_type = CXt_SUB;
2298                     cx->blk_sub.hasargs = 0;
2299                 }
2300                 cx->blk_sub.cv = cv;
2301                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2302
2303                 CvDEPTH(cv)++;
2304                 if (CvDEPTH(cv) < 2)
2305                     (void)SvREFCNT_inc(cv);
2306                 else {
2307                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2308                         sub_crush_depth(cv);
2309                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2310                 }
2311                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2312                 if (cx->blk_sub.hasargs)
2313                 {
2314                     AV* av = (AV*)PAD_SVl(0);
2315                     SV** ary;
2316
2317                     cx->blk_sub.savearray = GvAV(PL_defgv);
2318                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2319                     CX_CURPAD_SAVE(cx->blk_sub);
2320                     cx->blk_sub.argarray = av;
2321                     ++mark;
2322
2323                     if (items >= AvMAX(av) + 1) {
2324                         ary = AvALLOC(av);
2325                         if (AvARRAY(av) != ary) {
2326                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2327                             SvPVX(av) = (char*)ary;
2328                         }
2329                         if (items >= AvMAX(av) + 1) {
2330                             AvMAX(av) = items - 1;
2331                             Renew(ary,items+1,SV*);
2332                             AvALLOC(av) = ary;
2333                             SvPVX(av) = (char*)ary;
2334                         }
2335                     }
2336                     Copy(mark,AvARRAY(av),items,SV*);
2337                     AvFILLp(av) = items - 1;
2338                     assert(!AvREAL(av));
2339                     while (items--) {
2340                         if (*mark)
2341                             SvTEMP_off(*mark);
2342                         mark++;
2343                     }
2344                 }
2345                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2346                     /*
2347                      * We do not care about using sv to call CV;
2348                      * it's for informational purposes only.
2349                      */
2350                     SV *sv = GvSV(PL_DBsub);
2351                     CV *gotocv;
2352
2353                     if (PERLDB_SUB_NN) {
2354                         (void)SvUPGRADE(sv, SVt_PVIV);
2355                         (void)SvIOK_on(sv);
2356                         SAVEIV(SvIVX(sv));
2357                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2358                     } else {
2359                         save_item(sv);
2360                         gv_efullname3(sv, CvGV(cv), Nullch);
2361                     }
2362                     if (  PERLDB_GOTO
2363                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2364                         PUSHMARK( PL_stack_sp );
2365                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2366                         PL_stack_sp--;
2367                     }
2368                 }
2369                 RETURNOP(CvSTART(cv));
2370             }
2371         }
2372         else {
2373             label = SvPV(sv,n_a);
2374             if (!(do_dump || *label))
2375                 DIE(aTHX_ must_have_label);
2376         }
2377     }
2378     else if (PL_op->op_flags & OPf_SPECIAL) {
2379         if (! do_dump)
2380             DIE(aTHX_ must_have_label);
2381     }
2382     else
2383         label = cPVOP->op_pv;
2384
2385     if (label && *label) {
2386         OP *gotoprobe = 0;
2387         bool leaving_eval = FALSE;
2388         bool in_block = FALSE;
2389         PERL_CONTEXT *last_eval_cx = 0;
2390
2391         /* find label */
2392
2393         PL_lastgotoprobe = 0;
2394         *enterops = 0;
2395         for (ix = cxstack_ix; ix >= 0; ix--) {
2396             cx = &cxstack[ix];
2397             switch (CxTYPE(cx)) {
2398             case CXt_EVAL:
2399                 leaving_eval = TRUE;
2400                 if (!CxTRYBLOCK(cx)) {
2401                     gotoprobe = (last_eval_cx ?
2402                                 last_eval_cx->blk_eval.old_eval_root :
2403                                 PL_eval_root);
2404                     last_eval_cx = cx;
2405                     break;
2406                 }
2407                 /* else fall through */
2408             case CXt_LOOP:
2409                 gotoprobe = cx->blk_oldcop->op_sibling;
2410                 break;
2411             case CXt_SUBST:
2412                 continue;
2413             case CXt_BLOCK:
2414                 if (ix) {
2415                     gotoprobe = cx->blk_oldcop->op_sibling;
2416                     in_block = TRUE;
2417                 } else
2418                     gotoprobe = PL_main_root;
2419                 break;
2420             case CXt_SUB:
2421                 if (CvDEPTH(cx->blk_sub.cv)) {
2422                     gotoprobe = CvROOT(cx->blk_sub.cv);
2423                     break;
2424                 }
2425                 /* FALL THROUGH */
2426             case CXt_FORMAT:
2427             case CXt_NULL:
2428                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2429             default:
2430                 if (ix)
2431                     DIE(aTHX_ "panic: goto");
2432                 gotoprobe = PL_main_root;
2433                 break;
2434             }
2435             if (gotoprobe) {
2436                 retop = dofindlabel(gotoprobe, label,
2437                                     enterops, enterops + GOTO_DEPTH);
2438                 if (retop)
2439                     break;
2440             }
2441             PL_lastgotoprobe = gotoprobe;
2442         }
2443         if (!retop)
2444             DIE(aTHX_ "Can't find label %s", label);
2445
2446         /* if we're leaving an eval, check before we pop any frames
2447            that we're not going to punt, otherwise the error
2448            won't be caught */
2449
2450         if (leaving_eval && *enterops && enterops[1]) {
2451             I32 i;
2452             for (i = 1; enterops[i]; i++)
2453                 if (enterops[i]->op_type == OP_ENTERITER)
2454                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2455         }
2456
2457         /* pop unwanted frames */
2458
2459         if (ix < cxstack_ix) {
2460             I32 oldsave;
2461
2462             if (ix < 0)
2463                 ix = 0;
2464             dounwind(ix);
2465             TOPBLOCK(cx);
2466             oldsave = PL_scopestack[PL_scopestack_ix];
2467             LEAVE_SCOPE(oldsave);
2468         }
2469
2470         /* push wanted frames */
2471
2472         if (*enterops && enterops[1]) {
2473             OP *oldop = PL_op;
2474             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2475             for (; enterops[ix]; ix++) {
2476                 PL_op = enterops[ix];
2477                 /* Eventually we may want to stack the needed arguments
2478                  * for each op.  For now, we punt on the hard ones. */
2479                 if (PL_op->op_type == OP_ENTERITER)
2480                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2481                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2482             }
2483             PL_op = oldop;
2484         }
2485     }
2486
2487     if (do_dump) {
2488 #ifdef VMS
2489         if (!retop) retop = PL_main_start;
2490 #endif
2491         PL_restartop = retop;
2492         PL_do_undump = TRUE;
2493
2494         my_unexec();
2495
2496         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2497         PL_do_undump = FALSE;
2498     }
2499
2500     RETURNOP(retop);
2501 }
2502
2503 PP(pp_exit)
2504 {
2505     dSP;
2506     I32 anum;
2507
2508     if (MAXARG < 1)
2509         anum = 0;
2510     else {
2511         anum = SvIVx(POPs);
2512 #ifdef VMS
2513         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2514             anum = 0;
2515         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2516 #endif
2517     }
2518     PL_exit_flags |= PERL_EXIT_EXPECTED;
2519     my_exit(anum);
2520     PUSHs(&PL_sv_undef);
2521     RETURN;
2522 }
2523
2524 #ifdef NOTYET
2525 PP(pp_nswitch)
2526 {
2527     dSP;
2528     NV value = SvNVx(GvSV(cCOP->cop_gv));
2529     register I32 match = I_32(value);
2530
2531     if (value < 0.0) {
2532         if (((NV)match) > value)
2533             --match;            /* was fractional--truncate other way */
2534     }
2535     match -= cCOP->uop.scop.scop_offset;
2536     if (match < 0)
2537         match = 0;
2538     else if (match > cCOP->uop.scop.scop_max)
2539         match = cCOP->uop.scop.scop_max;
2540     PL_op = cCOP->uop.scop.scop_next[match];
2541     RETURNOP(PL_op);
2542 }
2543
2544 PP(pp_cswitch)
2545 {
2546     dSP;
2547     register I32 match;
2548
2549     if (PL_multiline)
2550         PL_op = PL_op->op_next;                 /* can't assume anything */
2551     else {
2552         STRLEN n_a;
2553         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2554         match -= cCOP->uop.scop.scop_offset;
2555         if (match < 0)
2556             match = 0;
2557         else if (match > cCOP->uop.scop.scop_max)
2558             match = cCOP->uop.scop.scop_max;
2559         PL_op = cCOP->uop.scop.scop_next[match];
2560     }
2561     RETURNOP(PL_op);
2562 }
2563 #endif
2564
2565 /* Eval. */
2566
2567 STATIC void
2568 S_save_lines(pTHX_ AV *array, SV *sv)
2569 {
2570     register char *s = SvPVX(sv);
2571     register char *send = SvPVX(sv) + SvCUR(sv);
2572     register char *t;
2573     register I32 line = 1;
2574
2575     while (s && s < send) {
2576         SV *tmpstr = NEWSV(85,0);
2577
2578         sv_upgrade(tmpstr, SVt_PVMG);
2579         t = strchr(s, '\n');
2580         if (t)
2581             t++;
2582         else
2583             t = send;
2584
2585         sv_setpvn(tmpstr, s, t - s);
2586         av_store(array, line++, tmpstr);
2587         s = t;
2588     }
2589 }
2590
2591 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2592 STATIC void *
2593 S_docatch_body(pTHX_ va_list args)
2594 {
2595     return docatch_body();
2596 }
2597 #endif
2598
2599 STATIC void *
2600 S_docatch_body(pTHX)
2601 {
2602     CALLRUNOPS(aTHX);
2603     return NULL;
2604 }
2605
2606 STATIC OP *
2607 S_docatch(pTHX_ OP *o)
2608 {
2609     int ret;
2610     OP *oldop = PL_op;
2611     OP *retop;
2612     volatile PERL_SI *cursi = PL_curstackinfo;
2613     dJMPENV;
2614
2615 #ifdef DEBUGGING
2616     assert(CATCH_GET == TRUE);
2617 #endif
2618     PL_op = o;
2619
2620     /* Normally, the leavetry at the end of this block of ops will
2621      * pop an op off the return stack and continue there. By setting
2622      * the op to Nullop, we force an exit from the inner runops()
2623      * loop. DAPM.
2624      */
2625     retop = pop_return();
2626     push_return(Nullop);
2627
2628 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2629  redo_body:
2630     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2631 #else
2632     JMPENV_PUSH(ret);
2633 #endif
2634     switch (ret) {
2635     case 0:
2636 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2637  redo_body:
2638         docatch_body();
2639 #endif
2640         break;
2641     case 3:
2642         /* die caught by an inner eval - continue inner loop */
2643         if (PL_restartop && cursi == PL_curstackinfo) {
2644             PL_op = PL_restartop;
2645             PL_restartop = 0;
2646             goto redo_body;
2647         }
2648         /* a die in this eval - continue in outer loop */
2649         if (!PL_restartop)
2650             break;
2651         /* FALL THROUGH */
2652     default:
2653         JMPENV_POP;
2654         PL_op = oldop;
2655         JMPENV_JUMP(ret);
2656         /* NOTREACHED */
2657     }
2658     JMPENV_POP;
2659     PL_op = oldop;
2660     return retop;
2661 }
2662
2663 OP *
2664 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2665 /* sv Text to convert to OP tree. */
2666 /* startop op_free() this to undo. */
2667 /* code Short string id of the caller. */
2668 {
2669     dSP;                                /* Make POPBLOCK work. */
2670     PERL_CONTEXT *cx;
2671     SV **newsp;
2672     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2673     I32 optype;
2674     OP dummy;
2675     OP *rop;
2676     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2677     char *tmpbuf = tbuf;
2678     char *safestr;
2679     int runtime;
2680     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2681
2682     ENTER;
2683     lex_start(sv);
2684     SAVETMPS;
2685     /* switch to eval mode */
2686
2687     if (IN_PERL_COMPILETIME) {
2688         SAVECOPSTASH_FREE(&PL_compiling);
2689         CopSTASH_set(&PL_compiling, PL_curstash);
2690     }
2691     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2692         SV *sv = sv_newmortal();
2693         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2694                        code, (unsigned long)++PL_evalseq,
2695                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2696         tmpbuf = SvPVX(sv);
2697     }
2698     else
2699         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2700     SAVECOPFILE_FREE(&PL_compiling);
2701     CopFILE_set(&PL_compiling, tmpbuf+2);
2702     SAVECOPLINE(&PL_compiling);
2703     CopLINE_set(&PL_compiling, 1);
2704     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2705        deleting the eval's FILEGV from the stash before gv_check() runs
2706        (i.e. before run-time proper). To work around the coredump that
2707        ensues, we always turn GvMULTI_on for any globals that were
2708        introduced within evals. See force_ident(). GSAR 96-10-12 */
2709     safestr = savepv(tmpbuf);
2710     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2711     SAVEHINTS();
2712 #ifdef OP_IN_REGISTER
2713     PL_opsave = op;
2714 #else
2715     SAVEVPTR(PL_op);
2716 #endif
2717     PL_hints &= HINT_UTF8;
2718
2719     /* we get here either during compilation, or via pp_regcomp at runtime */
2720     runtime = IN_PERL_RUNTIME;
2721     if (runtime)
2722         runcv = find_runcv(NULL);
2723
2724     PL_op = &dummy;
2725     PL_op->op_type = OP_ENTEREVAL;
2726     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2727     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2728     PUSHEVAL(cx, 0, Nullgv);
2729
2730     if (runtime)
2731         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2732     else
2733         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2734     POPBLOCK(cx,PL_curpm);
2735     POPEVAL(cx);
2736
2737     (*startop)->op_type = OP_NULL;
2738     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2739     lex_end();
2740     /* XXX DAPM do this properly one year */
2741     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2742     LEAVE;
2743     if (IN_PERL_COMPILETIME)
2744         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2745 #ifdef OP_IN_REGISTER
2746     op = PL_opsave;
2747 #endif
2748     return rop;
2749 }
2750
2751
2752 /*
2753 =for apidoc find_runcv
2754
2755 Locate the CV corresponding to the currently executing sub or eval.
2756 If db_seqp is non_null, skip CVs that are in the DB package and populate
2757 *db_seqp with the cop sequence number at the point that the DB:: code was
2758 entered. (allows debuggers to eval in the scope of the breakpoint rather
2759 than in in the scope of the debuger itself).
2760
2761 =cut
2762 */
2763
2764 CV*
2765 Perl_find_runcv(pTHX_ U32 *db_seqp)
2766 {
2767     I32          ix;
2768     PERL_SI      *si;
2769     PERL_CONTEXT *cx;
2770
2771     if (db_seqp)
2772         *db_seqp = PL_curcop->cop_seq;
2773     for (si = PL_curstackinfo; si; si = si->si_prev) {
2774         for (ix = si->si_cxix; ix >= 0; ix--) {
2775             cx = &(si->si_cxstack[ix]);
2776             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2777                 CV *cv = cx->blk_sub.cv;
2778                 /* skip DB:: code */
2779                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2780                     *db_seqp = cx->blk_oldcop->cop_seq;
2781                     continue;
2782                 }
2783                 return cv;
2784             }
2785             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2786                 return PL_compcv;
2787         }
2788     }
2789     return PL_main_cv;
2790 }
2791
2792
2793 /* Compile a require/do, an eval '', or a /(?{...})/.
2794  * In the last case, startop is non-null, and contains the address of
2795  * a pointer that should be set to the just-compiled code.
2796  * outside is the lexically enclosing CV (if any) that invoked us.
2797  */
2798
2799 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2800 STATIC OP *
2801 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2802 {
2803     dSP;
2804     OP *saveop = PL_op;
2805
2806     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2807                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2808                   : EVAL_INEVAL);
2809
2810     PUSHMARK(SP);
2811
2812     SAVESPTR(PL_compcv);
2813     PL_compcv = (CV*)NEWSV(1104,0);
2814     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2815     CvEVAL_on(PL_compcv);
2816     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2817     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2818
2819     CvOUTSIDE_SEQ(PL_compcv) = seq;
2820     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2821
2822     /* set up a scratch pad */
2823
2824     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2825
2826
2827     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2828
2829     /* make sure we compile in the right package */
2830
2831     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2832         SAVESPTR(PL_curstash);
2833         PL_curstash = CopSTASH(PL_curcop);
2834     }
2835     SAVESPTR(PL_beginav);
2836     PL_beginav = newAV();
2837     SAVEFREESV(PL_beginav);
2838     SAVEI32(PL_error_count);
2839
2840     /* try to compile it */
2841
2842     PL_eval_root = Nullop;
2843     PL_error_count = 0;
2844     PL_curcop = &PL_compiling;
2845     PL_curcop->cop_arybase = 0;
2846     if (saveop && saveop->op_flags & OPf_SPECIAL)
2847         PL_in_eval |= EVAL_KEEPERR;
2848     else
2849         sv_setpv(ERRSV,"");
2850     if (yyparse() || PL_error_count || !PL_eval_root) {
2851         SV **newsp;                     /* Used by POPBLOCK. */
2852        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2853         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2854         STRLEN n_a;
2855
2856         PL_op = saveop;
2857         if (PL_eval_root) {
2858             op_free(PL_eval_root);
2859             PL_eval_root = Nullop;
2860         }
2861         SP = PL_stack_base + POPMARK;           /* pop original mark */
2862         if (!startop) {
2863             POPBLOCK(cx,PL_curpm);
2864             POPEVAL(cx);
2865             pop_return();
2866         }
2867         lex_end();
2868         LEAVE;
2869         if (optype == OP_REQUIRE) {
2870             char* msg = SvPVx(ERRSV, n_a);
2871            SV *nsv = cx->blk_eval.old_namesv;
2872            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2873                           &PL_sv_undef, 0);
2874             DIE(aTHX_ "%sCompilation failed in require",
2875                 *msg ? msg : "Unknown error\n");
2876         }
2877         else if (startop) {
2878             char* msg = SvPVx(ERRSV, n_a);
2879
2880             POPBLOCK(cx,PL_curpm);
2881             POPEVAL(cx);
2882             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2883                        (*msg ? msg : "Unknown error\n"));
2884         }
2885         else {
2886             char* msg = SvPVx(ERRSV, n_a);
2887             if (!*msg) {
2888                 sv_setpv(ERRSV, "Compilation error");
2889             }
2890         }
2891         RETPUSHUNDEF;
2892     }
2893     CopLINE_set(&PL_compiling, 0);
2894     if (startop) {
2895         *startop = PL_eval_root;
2896     } else
2897         SAVEFREEOP(PL_eval_root);
2898
2899     /* Set the context for this new optree.
2900      * If the last op is an OP_REQUIRE, force scalar context.
2901      * Otherwise, propagate the context from the eval(). */
2902     if (PL_eval_root->op_type == OP_LEAVEEVAL
2903             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2904             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2905             == OP_REQUIRE)
2906         scalar(PL_eval_root);
2907     else if (gimme & G_VOID)
2908         scalarvoid(PL_eval_root);
2909     else if (gimme & G_ARRAY)
2910         list(PL_eval_root);
2911     else
2912         scalar(PL_eval_root);
2913
2914     DEBUG_x(dump_eval());
2915
2916     /* Register with debugger: */
2917     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2918         CV *cv = get_cv("DB::postponed", FALSE);
2919         if (cv) {
2920             dSP;
2921             PUSHMARK(SP);
2922             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2923             PUTBACK;
2924             call_sv((SV*)cv, G_DISCARD);
2925         }
2926     }
2927
2928     /* compiled okay, so do it */
2929
2930     CvDEPTH(PL_compcv) = 1;
2931     SP = PL_stack_base + POPMARK;               /* pop original mark */
2932     PL_op = saveop;                     /* The caller may need it. */
2933     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2934
2935     RETURNOP(PL_eval_start);
2936 }
2937
2938 STATIC PerlIO *
2939 S_doopen_pm(pTHX_ const char *name, const char *mode)
2940 {
2941 #ifndef PERL_DISABLE_PMC
2942     STRLEN namelen = strlen(name);
2943     PerlIO *fp;
2944
2945     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2946         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2947         char *pmc = SvPV_nolen(pmcsv);
2948         Stat_t pmstat;
2949         Stat_t pmcstat;
2950         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2951             fp = PerlIO_open(name, mode);
2952         }
2953         else {
2954             if (PerlLIO_stat(name, &pmstat) < 0 ||
2955                 pmstat.st_mtime < pmcstat.st_mtime)
2956             {
2957                 fp = PerlIO_open(pmc, mode);
2958             }
2959             else {
2960                 fp = PerlIO_open(name, mode);
2961             }
2962         }
2963         SvREFCNT_dec(pmcsv);
2964     }
2965     else {
2966         fp = PerlIO_open(name, mode);
2967     }
2968     return fp;
2969 #else
2970     return PerlIO_open(name, mode);
2971 #endif /* !PERL_DISABLE_PMC */
2972 }
2973
2974 PP(pp_require)
2975 {
2976     dSP;
2977     register PERL_CONTEXT *cx;
2978     SV *sv;
2979     char *name;
2980     STRLEN len;
2981     char *tryname = Nullch;
2982     SV *namesv = Nullsv;
2983     SV** svp;
2984     I32 gimme = GIMME_V;
2985     PerlIO *tryrsfp = 0;
2986     STRLEN n_a;
2987     int filter_has_file = 0;
2988     GV *filter_child_proc = 0;
2989     SV *filter_state = 0;
2990     SV *filter_sub = 0;
2991     SV *hook_sv = 0;
2992     SV *encoding;
2993     OP *op;
2994
2995     sv = POPs;
2996     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2997         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2998             UV rev = 0, ver = 0, sver = 0;
2999             STRLEN len;
3000             U8 *s = (U8*)SvPVX(sv);
3001             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3002             if (s < end) {
3003                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3004                 s += len;
3005                 if (s < end) {
3006                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3007                     s += len;
3008                     if (s < end)
3009                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3010                 }
3011             }
3012             if (PERL_REVISION < rev
3013                 || (PERL_REVISION == rev
3014                     && (PERL_VERSION < ver
3015                         || (PERL_VERSION == ver
3016                             && PERL_SUBVERSION < sver))))
3017             {
3018                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3019                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3020                     PERL_VERSION, PERL_SUBVERSION);
3021             }
3022             if (ckWARN(WARN_PORTABLE))
3023                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3024                         "v-string in use/require non-portable");
3025             RETPUSHYES;
3026         }
3027         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3028             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3029                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3030                 + 0.00000099 < SvNV(sv))
3031             {
3032                 NV nrev = SvNV(sv);
3033                 UV rev = (UV)nrev;
3034                 NV nver = (nrev - rev) * 1000;
3035                 UV ver = (UV)(nver + 0.0009);
3036                 NV nsver = (nver - ver) * 1000;
3037                 UV sver = (UV)(nsver + 0.0009);
3038
3039                 /* help out with the "use 5.6" confusion */
3040                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3041                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3042                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3043                         "this is only v%d.%d.%d, stopped",
3044                         rev, ver, sver, rev, ver/100,
3045                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3046                 }
3047                 else {
3048                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3049                         "this is only v%d.%d.%d, stopped",
3050                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3051                         PERL_SUBVERSION);
3052                 }
3053             }
3054             RETPUSHYES;
3055         }
3056     }
3057     name = SvPV(sv, len);
3058     if (!(name && len > 0 && *name))
3059         DIE(aTHX_ "Null filename used");
3060     TAINT_PROPER("require");
3061     if (PL_op->op_type == OP_REQUIRE &&
3062        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3063        if (*svp != &PL_sv_undef)
3064            RETPUSHYES;
3065        else
3066            DIE(aTHX_ "Compilation failed in require");
3067     }
3068
3069     /* prepare to compile file */
3070
3071     if (path_is_absolute(name)) {
3072         tryname = name;
3073         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3074     }
3075 #ifdef MACOS_TRADITIONAL
3076     if (!tryrsfp) {
3077         char newname[256];
3078
3079         MacPerl_CanonDir(name, newname, 1);
3080         if (path_is_absolute(newname)) {
3081             tryname = newname;
3082             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3083         }
3084     }
3085 #endif
3086     if (!tryrsfp) {
3087         AV *ar = GvAVn(PL_incgv);
3088         I32 i;
3089 #ifdef VMS
3090         char *unixname;
3091         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3092 #endif
3093         {
3094             namesv = NEWSV(806, 0);
3095             for (i = 0; i <= AvFILL(ar); i++) {
3096                 SV *dirsv = *av_fetch(ar, i, TRUE);
3097
3098                 if (SvROK(dirsv)) {
3099                     int count;
3100                     SV *loader = dirsv;
3101
3102                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3103                         && !sv_isobject(loader))
3104                     {
3105                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3106                     }
3107
3108                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3109                                    PTR2UV(SvRV(dirsv)), name);
3110                     tryname = SvPVX(namesv);
3111                     tryrsfp = 0;
3112
3113                     ENTER;
3114                     SAVETMPS;
3115                     EXTEND(SP, 2);
3116
3117                     PUSHMARK(SP);
3118                     PUSHs(dirsv);
3119                     PUSHs(sv);
3120                     PUTBACK;
3121                     if (sv_isobject(loader))
3122                         count = call_method("INC", G_ARRAY);
3123                     else
3124                         count = call_sv(loader, G_ARRAY);
3125                     SPAGAIN;
3126
3127                     if (count > 0) {
3128                         int i = 0;
3129                         SV *arg;
3130
3131                         SP -= count - 1;
3132                         arg = SP[i++];
3133
3134                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3135                             arg = SvRV(arg);
3136                         }
3137
3138                         if (SvTYPE(arg) == SVt_PVGV) {
3139                             IO *io = GvIO((GV *)arg);
3140
3141                             ++filter_has_file;
3142
3143                             if (io) {
3144                                 tryrsfp = IoIFP(io);
3145                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3146                                     /* reading from a child process doesn't
3147                                        nest -- when returning from reading
3148                                        the inner module, the outer one is
3149                                        unreadable (closed?)  I've tried to
3150                                        save the gv to manage the lifespan of
3151                                        the pipe, but this didn't help. XXX */
3152                                     filter_child_proc = (GV *)arg;
3153                                     (void)SvREFCNT_inc(filter_child_proc);
3154                                 }
3155                                 else {
3156                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3157                                         PerlIO_close(IoOFP(io));
3158                                     }
3159                                     IoIFP(io) = Nullfp;
3160                                     IoOFP(io) = Nullfp;
3161                                 }
3162                             }
3163
3164                             if (i < count) {
3165                                 arg = SP[i++];
3166                             }
3167                         }
3168
3169                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3170                             filter_sub = arg;
3171                             (void)SvREFCNT_inc(filter_sub);
3172
3173                             if (i < count) {
3174                                 filter_state = SP[i];
3175                                 (void)SvREFCNT_inc(filter_state);
3176                             }
3177
3178                             if (tryrsfp == 0) {
3179                                 tryrsfp = PerlIO_open("/dev/null",
3180                                                       PERL_SCRIPT_MODE);
3181                             }
3182                         }
3183                         SP--;
3184                     }
3185
3186                     PUTBACK;
3187                     FREETMPS;
3188                     LEAVE;
3189
3190                     if (tryrsfp) {
3191                         hook_sv = dirsv;
3192                         break;
3193                     }
3194
3195                     filter_has_file = 0;
3196                     if (filter_child_proc) {
3197                         SvREFCNT_dec(filter_child_proc);
3198                         filter_child_proc = 0;
3199                     }
3200                     if (filter_state) {
3201                         SvREFCNT_dec(filter_state);
3202                         filter_state = 0;
3203                     }
3204                     if (filter_sub) {
3205                         SvREFCNT_dec(filter_sub);
3206                         filter_sub = 0;
3207                     }
3208                 }
3209                 else {
3210                   if (!path_is_absolute(name)
3211 #ifdef MACOS_TRADITIONAL
3212                         /* We consider paths of the form :a:b ambiguous and interpret them first
3213                            as global then as local
3214                         */
3215                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3216 #endif
3217                   ) {
3218                     char *dir = SvPVx(dirsv, n_a);
3219 #ifdef MACOS_TRADITIONAL
3220                     char buf1[256];
3221                     char buf2[256];
3222
3223                     MacPerl_CanonDir(name, buf2, 1);
3224                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3225 #else
3226 #ifdef VMS
3227                     char *unixdir;
3228                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3229                         continue;
3230                     sv_setpv(namesv, unixdir);
3231                     sv_catpv(namesv, unixname);
3232 #else
3233                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3234 #endif
3235 #endif
3236                     TAINT_PROPER("require");
3237                     tryname = SvPVX(namesv);
3238                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3239                     if (tryrsfp) {
3240                         if (tryname[0] == '.' && tryname[1] == '/')
3241                             tryname += 2;
3242                         break;
3243                     }
3244                   }
3245                 }
3246             }
3247         }
3248     }
3249     SAVECOPFILE_FREE(&PL_compiling);
3250     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3251     SvREFCNT_dec(namesv);
3252     if (!tryrsfp) {
3253         if (PL_op->op_type == OP_REQUIRE) {
3254             char *msgstr = name;
3255             if (namesv) {                       /* did we lookup @INC? */
3256                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3257                 SV *dirmsgsv = NEWSV(0, 0);
3258                 AV *ar = GvAVn(PL_incgv);
3259                 I32 i;
3260                 sv_catpvn(msg, " in @INC", 8);
3261                 if (instr(SvPVX(msg), ".h "))
3262                     sv_catpv(msg, " (change .h to .ph maybe?)");
3263                 if (instr(SvPVX(msg), ".ph "))
3264                     sv_catpv(msg, " (did you run h2ph?)");
3265                 sv_catpv(msg, " (@INC contains:");
3266                 for (i = 0; i <= AvFILL(ar); i++) {
3267                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3268                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3269                     sv_catsv(msg, dirmsgsv);
3270                 }
3271                 sv_catpvn(msg, ")", 1);
3272                 SvREFCNT_dec(dirmsgsv);
3273                 msgstr = SvPV_nolen(msg);
3274             }
3275             DIE(aTHX_ "Can't locate %s", msgstr);
3276         }
3277
3278         RETPUSHUNDEF;
3279     }
3280     else
3281         SETERRNO(0, SS_NORMAL);
3282
3283     /* Assume success here to prevent recursive requirement. */
3284     len = strlen(name);
3285     /* Check whether a hook in @INC has already filled %INC */
3286     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3287         (void)hv_store(GvHVn(PL_incgv), name, len,
3288                        (hook_sv ? SvREFCNT_inc(hook_sv)
3289                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3290                        0 );
3291     }
3292
3293     ENTER;
3294     SAVETMPS;
3295     lex_start(sv_2mortal(newSVpvn("",0)));
3296     SAVEGENERICSV(PL_rsfp_filters);
3297     PL_rsfp_filters = Nullav;
3298
3299     PL_rsfp = tryrsfp;
3300     SAVEHINTS();
3301     PL_hints = 0;
3302     SAVESPTR(PL_compiling.cop_warnings);
3303     if (PL_dowarn & G_WARN_ALL_ON)
3304         PL_compiling.cop_warnings = pWARN_ALL ;
3305     else if (PL_dowarn & G_WARN_ALL_OFF)
3306         PL_compiling.cop_warnings = pWARN_NONE ;
3307     else if (PL_taint_warn)
3308         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3309     else
3310         PL_compiling.cop_warnings = pWARN_STD ;
3311     SAVESPTR(PL_compiling.cop_io);
3312     PL_compiling.cop_io = Nullsv;
3313
3314     if (filter_sub || filter_child_proc) {
3315         SV *datasv = filter_add(run_user_filter, Nullsv);
3316         IoLINES(datasv) = filter_has_file;
3317         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3318         IoTOP_GV(datasv) = (GV *)filter_state;
3319         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3320     }
3321
3322     /* switch to eval mode */
3323     push_return(PL_op->op_next);
3324     PUSHBLOCK(cx, CXt_EVAL, SP);
3325     PUSHEVAL(cx, name, Nullgv);
3326
3327     SAVECOPLINE(&PL_compiling);
3328     CopLINE_set(&PL_compiling, 0);
3329
3330     PUTBACK;
3331
3332     /* Store and reset encoding. */
3333     encoding = PL_encoding;
3334     PL_encoding = Nullsv;
3335
3336     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3337
3338     /* Restore encoding. */
3339     PL_encoding = encoding;
3340
3341     return op;
3342 }
3343
3344 PP(pp_dofile)
3345 {
3346     return pp_require();
3347 }
3348
3349 PP(pp_entereval)
3350 {
3351     dSP;
3352     register PERL_CONTEXT *cx;
3353     dPOPss;
3354     I32 gimme = GIMME_V, was = PL_sub_generation;
3355     char tbuf[TYPE_DIGITS(long) + 12];
3356     char *tmpbuf = tbuf;
3357     char *safestr;
3358     STRLEN len;
3359     OP *ret;
3360     CV* runcv;
3361     U32 seq;
3362
3363     if (!SvPV(sv,len))
3364         RETPUSHUNDEF;
3365     TAINT_PROPER("eval");
3366
3367     ENTER;
3368     lex_start(sv);
3369     SAVETMPS;
3370
3371     /* switch to eval mode */
3372
3373     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3374         SV *sv = sv_newmortal();
3375         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3376                        (unsigned long)++PL_evalseq,
3377                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3378         tmpbuf = SvPVX(sv);
3379     }
3380     else
3381         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3382     SAVECOPFILE_FREE(&PL_compiling);
3383     CopFILE_set(&PL_compiling, tmpbuf+2);
3384     SAVECOPLINE(&PL_compiling);
3385     CopLINE_set(&PL_compiling, 1);
3386     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3387        deleting the eval's FILEGV from the stash before gv_check() runs
3388        (i.e. before run-time proper). To work around the coredump that
3389        ensues, we always turn GvMULTI_on for any globals that were
3390        introduced within evals. See force_ident(). GSAR 96-10-12 */
3391     safestr = savepv(tmpbuf);
3392     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3393     SAVEHINTS();
3394     PL_hints = PL_op->op_targ;
3395     SAVESPTR(PL_compiling.cop_warnings);
3396     if (specialWARN(PL_curcop->cop_warnings))
3397         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3398     else {
3399         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3400         SAVEFREESV(PL_compiling.cop_warnings);
3401     }
3402     SAVESPTR(PL_compiling.cop_io);
3403     if (specialCopIO(PL_curcop->cop_io))
3404         PL_compiling.cop_io = PL_curcop->cop_io;
3405     else {
3406         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3407         SAVEFREESV(PL_compiling.cop_io);
3408     }
3409     /* special case: an eval '' executed within the DB package gets lexically
3410      * placed in the first non-DB CV rather than the current CV - this
3411      * allows the debugger to execute code, find lexicals etc, in the
3412      * scope of the code being debugged. Passing &seq gets find_runcv
3413      * to do the dirty work for us */
3414     runcv = find_runcv(&seq);
3415
3416     push_return(PL_op->op_next);
3417     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3418     PUSHEVAL(cx, 0, Nullgv);
3419
3420     /* prepare to compile string */
3421
3422     if (PERLDB_LINE && PL_curstash != PL_debstash)
3423         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3424     PUTBACK;
3425     ret = doeval(gimme, NULL, runcv, seq);
3426     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3427         && ret != PL_op->op_next) {     /* Successive compilation. */
3428         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3429     }
3430     return DOCATCH(ret);
3431 }
3432
3433 PP(pp_leaveeval)
3434 {
3435     dSP;
3436     register SV **mark;
3437     SV **newsp;
3438     PMOP *newpm;
3439     I32 gimme;
3440     register PERL_CONTEXT *cx;
3441     OP *retop;
3442     U8 save_flags = PL_op -> op_flags;
3443     I32 optype;
3444
3445     POPBLOCK(cx,newpm);
3446     POPEVAL(cx);
3447     retop = pop_return();
3448
3449     TAINT_NOT;
3450     if (gimme == G_VOID)
3451         MARK = newsp;
3452     else if (gimme == G_SCALAR) {
3453         MARK = newsp + 1;
3454         if (MARK <= SP) {
3455             if (SvFLAGS(TOPs) & SVs_TEMP)
3456                 *MARK = TOPs;
3457             else
3458                 *MARK = sv_mortalcopy(TOPs);
3459         }
3460         else {
3461             MEXTEND(mark,0);
3462             *MARK = &PL_sv_undef;
3463         }
3464         SP = MARK;
3465     }
3466     else {
3467         /* in case LEAVE wipes old return values */
3468         for (mark = newsp + 1; mark <= SP; mark++) {
3469             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3470                 *mark = sv_mortalcopy(*mark);
3471                 TAINT_NOT;      /* Each item is independent */
3472             }
3473         }
3474     }
3475     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3476
3477 #ifdef DEBUGGING
3478     assert(CvDEPTH(PL_compcv) == 1);
3479 #endif
3480     CvDEPTH(PL_compcv) = 0;
3481     lex_end();
3482
3483     if (optype == OP_REQUIRE &&
3484         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3485     {
3486         /* Unassume the success we assumed earlier. */
3487         SV *nsv = cx->blk_eval.old_namesv;
3488         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3489         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3490         /* die_where() did LEAVE, or we won't be here */
3491     }
3492     else {
3493         LEAVE;
3494         if (!(save_flags & OPf_SPECIAL))
3495             sv_setpv(ERRSV,"");
3496     }
3497
3498     RETURNOP(retop);
3499 }
3500
3501 PP(pp_entertry)
3502 {
3503     dSP;
3504     register PERL_CONTEXT *cx;
3505     I32 gimme = GIMME_V;
3506
3507     ENTER;
3508     SAVETMPS;
3509
3510     push_return(cLOGOP->op_other->op_next);
3511     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3512     PUSHEVAL(cx, 0, 0);
3513
3514     PL_in_eval = EVAL_INEVAL;
3515     sv_setpv(ERRSV,"");
3516     PUTBACK;
3517     return DOCATCH(PL_op->op_next);
3518 }
3519
3520 PP(pp_leavetry)
3521 {
3522     dSP;
3523     register SV **mark;
3524     SV **newsp;
3525     PMOP *newpm;
3526     OP* retop;
3527     I32 gimme;
3528     register PERL_CONTEXT *cx;
3529     I32 optype;
3530
3531     POPBLOCK(cx,newpm);
3532     POPEVAL(cx);
3533     retop = pop_return();
3534
3535     TAINT_NOT;
3536     if (gimme == G_VOID)
3537         SP = newsp;
3538     else if (gimme == G_SCALAR) {
3539         MARK = newsp + 1;
3540         if (MARK <= SP) {
3541             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3542                 *MARK = TOPs;
3543             else
3544                 *MARK = sv_mortalcopy(TOPs);
3545         }
3546         else {
3547             MEXTEND(mark,0);
3548             *MARK = &PL_sv_undef;
3549         }
3550         SP = MARK;
3551     }
3552     else {
3553         /* in case LEAVE wipes old return values */
3554         for (mark = newsp + 1; mark <= SP; mark++) {
3555             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3556                 *mark = sv_mortalcopy(*mark);
3557                 TAINT_NOT;      /* Each item is independent */
3558             }
3559         }
3560     }
3561     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3562
3563     LEAVE;
3564     sv_setpv(ERRSV,"");
3565     RETURNOP(retop);
3566 }
3567
3568 STATIC OP *
3569 S_doparseform(pTHX_ SV *sv)
3570 {
3571     STRLEN len;
3572     register char *s = SvPV_force(sv, len);
3573     register char *send = s + len;
3574     register char *base = Nullch;
3575     register I32 skipspaces = 0;
3576     bool noblank   = FALSE;
3577     bool repeat    = FALSE;
3578     bool postspace = FALSE;
3579     U32 *fops;
3580     register U32 *fpc;
3581     U32 *linepc = 0;
3582     register I32 arg;
3583     bool ischop;
3584     bool unchopnum = FALSE;
3585     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3586
3587     if (len == 0)
3588         Perl_croak(aTHX_ "Null picture in formline");
3589
3590     /* estimate the buffer size needed */
3591     for (base = s; s <= send; s++) {
3592         if (*s == '\n' || *s == '@' || *s == '^')
3593             maxops += 10;
3594     }
3595     s = base;
3596     base = Nullch;
3597
3598     New(804, fops, maxops, U32);
3599     fpc = fops;
3600
3601     if (s < send) {
3602         linepc = fpc;
3603         *fpc++ = FF_LINEMARK;
3604         noblank = repeat = FALSE;
3605         base = s;
3606     }
3607
3608     while (s <= send) {
3609         switch (*s++) {
3610         default:
3611             skipspaces = 0;
3612             continue;
3613
3614         case '~':
3615             if (*s == '~') {
3616                 repeat = TRUE;
3617                 *s = ' ';
3618             }
3619             noblank = TRUE;
3620             s[-1] = ' ';
3621             /* FALL THROUGH */
3622         case ' ': case '\t':
3623             skipspaces++;
3624             continue;
3625         case 0:
3626             if (s < send) {
3627                 skipspaces = 0;
3628                 continue;
3629             } /* else FALL THROUGH */
3630         case '\n':
3631             arg = s - base;
3632             skipspaces++;
3633             arg -= skipspaces;
3634             if (arg) {
3635                 if (postspace)
3636                     *fpc++ = FF_SPACE;
3637                 *fpc++ = FF_LITERAL;
3638                 *fpc++ = (U16)arg;
3639             }
3640             postspace = FALSE;
3641             if (s <= send)
3642                 skipspaces--;
3643             if (skipspaces) {
3644                 *fpc++ = FF_SKIP;
3645                 *fpc++ = (U16)skipspaces;
3646             }
3647             skipspaces = 0;
3648             if (s <= send)
3649                 *fpc++ = FF_NEWLINE;
3650             if (noblank) {
3651                 *fpc++ = FF_BLANK;
3652                 if (repeat)
3653                     arg = fpc - linepc + 1;
3654                 else
3655                     arg = 0;
3656                 *fpc++ = (U16)arg;
3657             }
3658             if (s < send) {
3659                 linepc = fpc;
3660                 *fpc++ = FF_LINEMARK;
3661                 noblank = repeat = FALSE;
3662                 base = s;
3663             }
3664             else
3665                 s++;
3666             continue;
3667
3668         case '@':
3669         case '^':
3670             ischop = s[-1] == '^';
3671
3672             if (postspace) {
3673                 *fpc++ = FF_SPACE;
3674                 postspace = FALSE;
3675             }
3676             arg = (s - base) - 1;
3677             if (arg) {
3678                 *fpc++ = FF_LITERAL;
3679                 *fpc++ = (U16)arg;
3680             }
3681
3682             base = s - 1;
3683             *fpc++ = FF_FETCH;
3684             if (*s == '*') {
3685                 s++;
3686                 *fpc++ = 2;  /* skip the @* or ^* */
3687                 if (ischop) {
3688                     *fpc++ = FF_LINESNGL;
3689                     *fpc++ = FF_CHOP;
3690                 } else
3691                     *fpc++ = FF_LINEGLOB;
3692             }
3693             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3694                 arg = ischop ? 512 : 0;
3695                 base = s - 1;
3696                 while (*s == '#')
3697                     s++;
3698                 if (*s == '.') {
3699                     char *f;
3700                     s++;
3701                     f = s;
3702                     while (*s == '#')
3703                         s++;
3704                     arg |= 256 + (s - f);
3705                 }
3706                 *fpc++ = s - base;              /* fieldsize for FETCH */
3707                 *fpc++ = FF_DECIMAL;
3708                 *fpc++ = (U16)arg;
3709                 unchopnum |= ! ischop;
3710             }
3711             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3712                 arg = ischop ? 512 : 0;
3713                 base = s - 1;
3714                 s++;                                /* skip the '0' first */
3715                 while (*s == '#')
3716                     s++;
3717                 if (*s == '.') {
3718                     char *f;
3719                     s++;
3720                     f = s;
3721                     while (*s == '#')
3722                         s++;
3723                     arg |= 256 + (s - f);
3724                 }
3725                 *fpc++ = s - base;                /* fieldsize for FETCH */
3726                 *fpc++ = FF_0DECIMAL;
3727                 *fpc++ = (U16)arg;
3728                 unchopnum |= ! ischop;
3729             }
3730             else {
3731                 I32 prespace = 0;
3732                 bool ismore = FALSE;
3733
3734                 if (*s == '>') {
3735                     while (*++s == '>') ;
3736                     prespace = FF_SPACE;
3737                 }
3738                 else if (*s == '|') {
3739                     while (*++s == '|') ;
3740                     prespace = FF_HALFSPACE;
3741                     postspace = TRUE;
3742                 }
3743                 else {
3744                     if (*s == '<')
3745                         while (*++s == '<') ;
3746                     postspace = TRUE;
3747                 }
3748                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3749                     s += 3;
3750                     ismore = TRUE;
3751                 }
3752                 *fpc++ = s - base;              /* fieldsize for FETCH */
3753
3754                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3755
3756                 if (prespace)
3757                     *fpc++ = (U16)prespace;
3758                 *fpc++ = FF_ITEM;
3759                 if (ismore)
3760                     *fpc++ = FF_MORE;
3761                 if (ischop)
3762                     *fpc++ = FF_CHOP;
3763             }
3764             base = s;
3765             skipspaces = 0;
3766             continue;
3767         }
3768     }
3769     *fpc++ = FF_END;
3770
3771     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3772     arg = fpc - fops;
3773     { /* need to jump to the next word */
3774         int z;
3775         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3776         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3777         s = SvPVX(sv) + SvCUR(sv) + z;
3778     }
3779     Copy(fops, s, arg, U32);
3780     Safefree(fops);
3781     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3782     SvCOMPILED_on(sv);
3783
3784     if (unchopnum && repeat)
3785         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3786     return 0;
3787 }
3788
3789
3790 STATIC bool
3791 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3792 {
3793     /* Can value be printed in fldsize chars, using %*.*f ? */
3794     NV pwr = 1;
3795     NV eps = 0.5;
3796     bool res = FALSE;
3797     int intsize = fldsize - (value < 0 ? 1 : 0);
3798
3799     if (frcsize & 256)
3800         intsize--;
3801     frcsize &= 255;
3802     intsize -= frcsize;
3803
3804     while (intsize--) pwr *= 10.0;
3805     while (frcsize--) eps /= 10.0;
3806
3807     if( value >= 0 ){
3808         if (value + eps >= pwr)
3809             res = TRUE;
3810     } else {
3811         if (value - eps <= -pwr)
3812             res = TRUE;
3813     }
3814     return res;
3815 }
3816
3817 static I32
3818 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3819 {
3820     SV *datasv = FILTER_DATA(idx);
3821     int filter_has_file = IoLINES(datasv);
3822     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3823     SV *filter_state = (SV *)IoTOP_GV(datasv);
3824     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3825     int len = 0;
3826
3827     /* I was having segfault trouble under Linux 2.2.5 after a
3828        parse error occured.  (Had to hack around it with a test
3829        for PL_error_count == 0.)  Solaris doesn't segfault --
3830        not sure where the trouble is yet.  XXX */
3831
3832     if (filter_has_file) {
3833         len = FILTER_READ(idx+1, buf_sv, maxlen);
3834     }
3835
3836     if (filter_sub && len >= 0) {
3837         dSP;
3838         int count;
3839
3840         ENTER;
3841         SAVE_DEFSV;
3842         SAVETMPS;
3843         EXTEND(SP, 2);
3844
3845         DEFSV = buf_sv;
3846         PUSHMARK(SP);
3847         PUSHs(sv_2mortal(newSViv(maxlen)));
3848         if (filter_state) {
3849             PUSHs(filter_state);
3850         }
3851         PUTBACK;
3852         count = call_sv(filter_sub, G_SCALAR);
3853         SPAGAIN;
3854
3855         if (count > 0) {
3856             SV *out = POPs;
3857             if (SvOK(out)) {
3858                 len = SvIV(out);
3859             }
3860         }
3861
3862         PUTBACK;
3863         FREETMPS;
3864         LEAVE;
3865     }
3866
3867     if (len <= 0) {
3868         IoLINES(datasv) = 0;
3869         if (filter_child_proc) {
3870             SvREFCNT_dec(filter_child_proc);
3871             IoFMT_GV(datasv) = Nullgv;
3872         }
3873         if (filter_state) {
3874             SvREFCNT_dec(filter_state);
3875             IoTOP_GV(datasv) = Nullgv;
3876         }
3877         if (filter_sub) {
3878             SvREFCNT_dec(filter_sub);
3879             IoBOTTOM_GV(datasv) = Nullgv;
3880         }
3881         filter_del(run_user_filter);
3882     }
3883
3884     return len;
3885 }
3886
3887 /* perhaps someone can come up with a better name for
3888    this?  it is not really "absolute", per se ... */
3889 static bool
3890 S_path_is_absolute(pTHX_ char *name)
3891 {
3892     if (PERL_FILE_IS_ABSOLUTE(name)
3893 #ifdef MACOS_TRADITIONAL
3894         || (*name == ':'))
3895 #else
3896         || (*name == '.' && (name[1] == '/' ||
3897                              (name[1] == '.' && name[2] == '/'))))
3898 #endif
3899     {
3900         return TRUE;
3901     }
3902     else
3903         return FALSE;
3904 }