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