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