pp_ctl.c

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