pp_ctl.c

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