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